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
22 ;; $Id: pxml3.cl,v 1.1 2002/10/15 12:23:03 kevin Exp $
24 (in-package :net.xml.parser)
26 (pxml-dribble-bug-hook "$Id: pxml3.cl,v 1.1 2002/10/15 12:23:03 kevin Exp $")
28 (defvar *debug-dtd* nil)
30 (defun parse-dtd (tokenbuf
31 external external-callback)
32 (declare (optimize (speed 3) (safety 1)))
36 (multiple-value-bind (val kind)
37 (next-dtd-token tokenbuf
38 external include-count external-callback)
39 (if* (eq kind :end-dtd) then
40 (return (nreverse guts))
41 elseif (eq kind :include) then
43 elseif (eq kind :ignore) then nil
44 elseif (eq kind :include-end) then
45 (if* (> include-count 0) then (decf include-count)
46 else (xml-error "unexpected ']]>' token"))
47 else (when (iostruct-do-entity tokenbuf) (push val guts)))))))
49 (defparameter dtd-parser-states ())
51 (macrolet ((def-dtd-parser-state (var val)
52 `(progn (eval-when (compile load eval) (defconstant ,var ,val))
53 (pushnew '(,val . ,var) dtd-parser-states :key #'car))))
54 (def-dtd-parser-state state-dtdstart 0)
55 (def-dtd-parser-state state-tokenstart 1)
56 (def-dtd-parser-state state-dtd-? 2)
57 (def-dtd-parser-state state-dtd-! 3)
58 (def-dtd-parser-state state-dtd-comment 4)
59 (def-dtd-parser-state state-dtd-!-token 5)
60 (def-dtd-parser-state state-dtd-!-element 6)
61 (def-dtd-parser-state state-dtd-!-element-name 7)
62 (def-dtd-parser-state state-dtd-!-element-content 8)
63 (def-dtd-parser-state state-dtd-!-element-type 9)
64 (def-dtd-parser-state state-dtd-!-element-type-paren 10)
65 (def-dtd-parser-state state-dtd-!-element-type-token 11)
66 (def-dtd-parser-state state-dtd-!-element-type-end 12)
67 (def-dtd-parser-state state-dtd-!-element-type-paren-name 13)
68 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd 14)
69 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd2 15)
70 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd3 16)
71 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd4 17)
72 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd5 18)
73 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd6 19)
74 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd7 20)
75 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd8 21)
76 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd9 22)
77 (def-dtd-parser-state state-dtd-!-element-type-paren-name2 23)
78 ;;(def-dtd-parser-state state-dtd-!-element-type-paren-seq 24) folded into choice
79 (def-dtd-parser-state state-dtd-!-element-type-paren-choice 25)
80 (def-dtd-parser-state state-dtd-!-element-type-paren2 26)
81 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name 27)
82 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-paren 28)
83 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name2 29)
84 (def-dtd-parser-state state-dtd-!-element-type-paren3 30)
85 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name3 31)
86 (def-dtd-parser-state state-dtd-!-attlist 32)
87 (def-dtd-parser-state state-dtd-!-attlist-name 33)
88 (def-dtd-parser-state state-dtd-!-attdef 34)
89 (def-dtd-parser-state state-dtd-!-attdef-name 35)
90 (def-dtd-parser-state state-dtd-!-attdef-type 36)
91 ;;(def-dtd-parser-state state-dtd-!-attdef-enumeration 37)
92 (def-dtd-parser-state state-dtd-!-attdef-decl 38)
93 (def-dtd-parser-state state-dtd-!-attdef-decl-type 39)
94 (def-dtd-parser-state state-dtd-!-attdef-decl-value 40)
95 (def-dtd-parser-state state-dtd-!-attdef-decl-value2 41)
96 (def-dtd-parser-state state-dtd-!-attdef-decl-value3 42)
97 (def-dtd-parser-state state-dtd-!-attdef-decl-value4 43)
98 (def-dtd-parser-state state-dtd-!-attdef-decl-value5 44)
99 (def-dtd-parser-state state-dtd-!-attdef-decl-value6 45)
100 (def-dtd-parser-state state-dtd-!-attdef-decl-value7 46)
101 (def-dtd-parser-state state-dtd-!-attdef-notation 47)
102 (def-dtd-parser-state state-dtd-!-attdef-notation2 48)
103 (def-dtd-parser-state state-dtd-!-attdef-notation3 49)
104 (def-dtd-parser-state state-dtd-!-attdef-notation4 50)
105 (def-dtd-parser-state state-dtd-!-attdef-type2 51)
106 (def-dtd-parser-state state-dtd-!-entity 52)
107 (def-dtd-parser-state state-dtd-!-entity2 53)
108 (def-dtd-parser-state state-dtd-!-entity3 54)
109 (def-dtd-parser-state state-dtd-!-entity4 55)
110 (def-dtd-parser-state state-dtd-!-entity-value 56)
111 (def-dtd-parser-state state-dtd-!-entity5 57)
112 (def-dtd-parser-state state-dtd-!-entity6 58)
113 (def-dtd-parser-state state-!-dtd-system 59)
114 (def-dtd-parser-state state-!-dtd-public 60)
115 (def-dtd-parser-state state-!-dtd-system2 61)
116 (def-dtd-parser-state state-!-dtd-system3 62)
117 (def-dtd-parser-state state-!-dtd-system4 63)
118 (def-dtd-parser-state state-!-dtd-system5 64)
119 (def-dtd-parser-state state-!-dtd-system6 65)
120 (def-dtd-parser-state state-!-dtd-system7 66)
121 (def-dtd-parser-state state-!-dtd-public2 67)
122 (def-dtd-parser-state state-dtd-!-notation 68)
123 (def-dtd-parser-state state-dtd-!-notation2 69)
124 (def-dtd-parser-state state-dtd-!-notation3 70)
125 (def-dtd-parser-state state-dtd-?-2 71)
126 (def-dtd-parser-state state-dtd-?-3 72)
127 (def-dtd-parser-state state-dtd-?-4 73)
128 (def-dtd-parser-state state-dtd-comment2 74)
129 (def-dtd-parser-state state-dtd-comment3 75)
130 (def-dtd-parser-state state-dtd-comment4 76)
131 (def-dtd-parser-state state-dtd-!-entity7 77)
132 (def-dtd-parser-state state-dtd-!-attdef-notation5 78)
133 (def-dtd-parser-state state-!-dtd-public3 79)
134 (def-dtd-parser-state state-dtd-!-cond 80)
135 (def-dtd-parser-state state-dtd-!-cond2 81)
136 (def-dtd-parser-state state-dtd-!-include 82)
137 (def-dtd-parser-state state-dtd-!-ignore 83)
138 (def-dtd-parser-state state-dtd-!-include2 84)
139 (def-dtd-parser-state state-dtd-!-include3 85)
140 (def-dtd-parser-state state-dtd-!-include4 86)
141 (def-dtd-parser-state state-dtd-!-ignore2 87)
142 (def-dtd-parser-state state-dtd-!-ignore3 88)
143 (def-dtd-parser-state state-dtd-!-ignore4 89)
144 (def-dtd-parser-state state-dtd-!-ignore5 90)
145 (def-dtd-parser-state state-dtd-!-ignore6 91)
146 (def-dtd-parser-state state-dtd-!-ignore7 92)
149 (defun next-dtd-token (tokenbuf
150 external include-count external-callback)
151 (declare (:fbound parse-default-value) (optimize (speed 3) (safety 1)))
152 (macrolet ((add-to-entity-buf (entity-symbol p-value)
154 (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
155 (iostruct-entity-bufs tokenbuf))))
158 `(push ,ch (iostruct-unget-char tokenbuf)))
161 `(setf (collector-next ,coll) 0))
163 (add-to-coll (coll ch)
164 `(let ((.next. (collector-next ,coll)))
165 (if* (>= .next. (collector-max ,coll))
166 then (grow-and-add ,coll ,ch)
167 else (setf (schar (collector-data ,coll) .next.)
169 (setf (collector-next ,coll) (1+ .next.)))))
171 (to-preferred-case (ch)
172 ;; should check the case mode
173 `(char-downcase ,ch))
176 (let ((state state-dtdstart)
177 (coll (get-collector))
178 (entity (get-collector))
188 (reference-save-state)
195 (setq ch (get-next-char tokenbuf))
197 (format t "~@<dtd ~:Ichar: ~s ~:_state: ~s ~:_contents: ~s ~:_pending: ~s ~:_pending-type: ~s ~:_entity-names ~s~:>~%"
198 ch (or (cdr (assoc state dtd-parser-states)) state)
199 contents-to-return pending pending-type
200 (iostruct-entity-names tokenbuf)))
202 then (setf prev-state state)
204 (return) ;; eof -- exit loop
209 (if* (and (eq #\] ch)
210 external (> include-count 0)) then
211 (setf state state-dtd-!-include3)
212 elseif (and (eq #\] ch) (not external)) then (return)
213 elseif (eq #\< ch) then (setf state state-tokenstart)
214 elseif (xml-space-p ch) then nil
215 elseif (eq #\% ch) then (external-param-reference tokenbuf coll external-callback)
217 (add-to-coll coll ch)
218 (setq ch (get-next-char tokenbuf))
221 (xml-error (concatenate 'string
222 "illegal DTD characters, starting at: '"
223 (compute-coll-string coll)
226 (#.state-dtd-!-include3
227 (if* (eq #\] ch) then (setf state state-dtd-!-include4)
230 (add-to-coll coll ch)
231 (setq ch (get-next-char tokenbuf))
234 (xml-error (concatenate 'string
235 "illegal DTD token, starting at: ']"
236 (compute-coll-string coll)
238 (#.state-dtd-!-include4
239 (if* (eq #\> ch) then (return)
242 (add-to-coll coll ch)
243 (setq ch (get-next-char tokenbuf))
246 (xml-error (concatenate 'string
247 "illegal DTD token, starting at: ']]"
248 (compute-coll-string coll)
252 (if* (xml-name-start-char-p ch) then
253 (add-to-coll coll ch)
254 (setf state state-dtd-pref2)
256 (add-to-coll coll ch)
257 (setq ch (get-next-char tokenbuf))
260 (xml-error (concatenate 'string
261 "illegal DTD parameter reference name, starting at: '"
262 (compute-coll-string coll)
266 (if* (eq #\? ch) then (setf state state-dtd-?)
267 elseif (eq #\! ch) then (setf state state-dtd-!)
269 (add-to-coll coll ch)
270 (setq ch (get-next-char tokenbuf))
273 (xml-error (concatenate 'string
274 "illegal DTD characters, starting at: '<"
275 (compute-coll-string coll)
279 (if* (xml-name-char-p ch)
281 (add-to-coll coll ch)
282 elseif (and external (eq #\% ch)) then
283 (external-param-reference tokenbuf coll external-callback)
285 (when (not (xml-space-p ch))
286 (xml-error (concatenate 'string
287 "expecting name following: '<?"
288 (compute-coll-string coll)
289 "' ; got: '" (string ch) "'"))
291 (when (= (collector-next coll) 0)
292 (xml-error "null <? token"))
293 (if* (and (= (collector-next coll) 3)
294 (or (eq (elt (collector-data coll) 0) #\X)
295 (eq (elt (collector-data coll) 0) #\x))
296 (or (eq (elt (collector-data coll) 1) #\M)
297 (eq (elt (collector-data coll) 1) #\m))
298 (or (eq (elt (collector-data coll) 2) #\L)
299 (eq (elt (collector-data coll) 2) #\l)))
301 (xml-error "<?xml not allowed in dtd")
303 (setq tag-to-return (compute-tag coll))
304 (setf state state-dtd-?-2))
307 (if* (xml-space-p ch)
309 elseif (and external (eq #\% ch)) then
310 (external-param-reference tokenbuf coll external-callback)
311 elseif (not (xml-char-p ch))
312 then (xml-error "XML is not well formed") ;; no test
313 else (add-to-coll coll ch)
314 (setf state state-dtd-?-3)))
317 then (setf state state-dtd-?-4)
318 elseif (not (xml-char-p ch))
319 then (xml-error "XML is not well formed") ;; no test
320 else (add-to-coll coll ch)))
324 (push (compute-coll-string coll) contents-to-return)
327 else (setf state state-dtd-?-3)
328 (add-to-coll coll #\?)
329 (add-to-coll coll ch)))
331 (if* (eq #\- ch) then (setf state state-dtd-comment)
332 elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-token)
334 elseif (and (eq #\[ ch) external) then
335 (setf state state-dtd-!-cond)
337 (add-to-coll coll ch)
338 (setq ch (get-next-char tokenbuf))
341 (xml-error (concatenate 'string
342 "illegal DTD characters, starting at: '<!"
343 (compute-coll-string coll)
347 (if* (xml-space-p ch) then nil
348 elseif (and external (eq #\% ch)) then
349 (external-param-reference tokenbuf coll external-callback)
350 elseif (eq #\I ch) then (setf state state-dtd-!-cond2)
351 else (error "this should not happen")
354 (if* (eq #\N ch) then (setf state state-dtd-!-include)
356 elseif (eq #\G ch) then (setf state state-dtd-!-ignore)
358 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
360 (#.state-dtd-!-ignore
361 (if* (and (eq check-count 5) (eq ch #\E)) then
362 (setf state state-dtd-!-ignore2)
363 elseif (eq ch (elt "IGNORE" check-count)) then
365 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
367 (#.state-dtd-!-ignore2
368 (if* (xml-space-p ch) then nil
369 elseif (and external (eq #\% ch)) then
370 (external-param-reference tokenbuf coll external-callback)
371 elseif (eq #\[ ch) then (setf state state-dtd-!-ignore3)
373 else (xml-error "'[' missing after '<![Ignore'")))
374 (#.state-dtd-!-ignore3
375 (if* (eq #\< ch) then (setf state state-dtd-!-ignore4)
376 elseif (eq #\] ch) then (setf state state-dtd-!-ignore5)))
377 (#.state-dtd-!-ignore4
378 (if* (eq #\! ch) then (setf state state-dtd-!-ignore6)
379 else (un-next-char ch)
380 (setf state state-dtd-!-ignore3)))
381 (#.state-dtd-!-ignore5
382 (if* (eq #\] ch) then (setf state state-dtd-!-ignore7)
383 else (un-next-char ch)
384 (setf state state-dtd-!-ignore3)))
385 (#.state-dtd-!-ignore6
386 (if* (eq #\[ ch) then (incf ignore-count)
387 (setf state state-dtd-!-ignore3)
388 else (un-next-char ch)
389 (setf state state-dtd-!-ignore3)))
390 (#.state-dtd-!-ignore7
391 (if* (eq #\> ch) then (decf ignore-count)
392 (when (= ignore-count 0) (return))
393 else (un-next-char ch)
394 (setf state state-dtd-!-ignore3)))
395 (#.state-dtd-!-include
396 (if* (and (eq check-count 6) (eq ch #\E)) then
397 (setf state state-dtd-!-include2)
398 elseif (eq ch (elt "INCLUD" check-count)) then
400 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
402 (#.state-dtd-!-include2
403 (if* (xml-space-p ch) then nil
404 elseif (and external (eq #\% ch)) then
405 (external-param-reference tokenbuf coll external-callback)
406 elseif (eq #\[ ch) then (return)
407 else (xml-error "'[' missing after '<![INCLUDE'")))
410 then (setf state state-dtd-comment2)
411 (setf tag-to-return :comment)
412 else (clear-coll coll)
414 (add-to-coll coll ch)
415 (setq ch (get-next-char tokenbuf))
418 (xml-error (concatenate 'string
419 "illegal token following '<![-', starting at '<!-"
420 (compute-coll-string coll)
423 (#.state-dtd-comment2
425 then (setf state state-dtd-comment3)
426 else (add-to-coll coll ch)))
427 (#.state-dtd-comment3
429 then (setf state state-dtd-comment4)
430 else (setf state state-dtd-comment2)
431 (add-to-coll coll #\-) (add-to-coll coll ch)))
432 (#.state-dtd-comment4
434 then (push (compute-coll-string coll) contents-to-return)
437 else (clear-coll coll)
439 (add-to-coll coll ch)
440 (setq ch (get-next-char tokenbuf))
443 (xml-error (concatenate 'string
444 "illegal token following '--' comment terminator, starting at '--"
445 (compute-coll-string coll)
449 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
450 elseif (and external (eq #\% ch)) then
451 (external-param-reference tokenbuf coll external-callback)
452 elseif (xml-space-p ch) then
453 (setf tag-to-return (compute-tag coll))
455 (if* (eq tag-to-return :ELEMENT) then (setf state state-dtd-!-element)
456 elseif (eq tag-to-return :ATTLIST) then
457 (setf state state-dtd-!-attlist)
458 elseif (eq tag-to-return :ENTITY) then
460 (setf state state-dtd-!-entity)
461 elseif (eq tag-to-return :NOTATION) then
462 (setf state state-dtd-!-notation)
464 (xml-error (concatenate 'string
465 "illegal DTD characters, starting at: '<!"
466 (string tag-to-return)
469 (add-to-coll coll ch)
470 (setq ch (get-next-char tokenbuf))
473 (xml-error (concatenate 'string
474 "illegal DTD characters, starting at: '<!"
475 (compute-coll-string coll)
478 (#.state-dtd-!-notation
479 (if* (xml-space-p ch) then nil
480 elseif (and external (eq #\% ch)) then
481 (external-param-reference tokenbuf coll external-callback)
482 elseif (xml-name-start-char-p ch) then
483 (add-to-coll coll ch)
484 (setf state state-dtd-!-notation2)
486 (add-to-coll coll ch)
487 (setq ch (get-next-char tokenbuf))
490 (xml-error (concatenate 'string
491 "illegal DTD characters, starting at: '<!NOTATION "
492 (compute-coll-string coll)
495 (#.state-dtd-!-notation2
496 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
497 elseif (and external (eq #\% ch)) then
498 (external-param-reference tokenbuf coll external-callback)
499 elseif (xml-space-p ch) then
500 (push (compute-tag coll) contents-to-return)
502 (setf state state-dtd-!-notation3)
504 (add-to-coll coll ch)
505 (setq ch (get-next-char tokenbuf))
508 (xml-error (concatenate 'string
509 "illegal DTD <!NOTATION name: "
510 (compute-coll-string coll)
513 (#.state-dtd-!-notation3
514 (if* (xml-space-p ch) then nil
515 elseif (and external (eq #\% ch)) then
516 (external-param-reference tokenbuf coll external-callback)
517 elseif (xml-name-char-p ch) then
518 (add-to-coll coll ch)
519 (setf state state-dtd-!-entity6)
521 (add-to-coll coll ch)
522 (setq ch (get-next-char tokenbuf))
525 (xml-error (concatenate 'string
526 "illegal DTD <!NOTATION spec for "
527 (string (first contents-to-return))
529 (compute-coll-string coll)
532 (#.state-dtd-!-entity
533 (if* (eq #\% ch) then (push :param contents-to-return)
535 (setf state state-dtd-!-entity2)
536 elseif (xml-name-start-char-p ch) then
537 (add-to-coll coll ch)
539 (setf state state-dtd-!-entity3)
540 elseif (xml-space-p ch) then nil
541 elseif (and external (eq #\% ch)) then
542 (external-param-reference tokenbuf coll external-callback)
544 (add-to-coll coll ch)
545 (setq ch (get-next-char tokenbuf))
548 (xml-error (concatenate 'string
549 "illegal DTD characters, starting at: '<!ENTITY "
550 (compute-coll-string coll)
553 (#.state-dtd-!-entity2
554 (if* (xml-space-p ch) then (setf state state-dtd-!-entity7)
555 elseif (and external (eq #\% ch)) then
556 (external-param-reference tokenbuf coll external-callback)
558 (add-to-coll coll ch)
559 (setq ch (get-next-char tokenbuf))
562 (xml-error (concatenate 'string
563 "illegal DTD <!ENTITY spec for "
564 (string (first contents-to-return))
566 (compute-coll-string coll)
569 (#.state-dtd-!-entity3
570 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
571 elseif (and external (eq #\% ch)) then
572 (external-param-reference tokenbuf coll external-callback)
573 elseif (xml-space-p ch) then
574 (push (compute-tag coll) contents-to-return)
575 (setf contents-to-return
576 (nreverse contents-to-return))
578 (setf state state-dtd-!-entity4)
580 (add-to-coll coll ch)
581 (setq ch (get-next-char tokenbuf))
584 (xml-error (concatenate 'string
585 "illegal DTD <!ENTITY name: "
586 (compute-coll-string coll)
589 (#.state-dtd-!-entity4
590 (if* (xml-space-p ch) then nil
591 elseif (and external (eq #\% ch)) then
592 (external-param-reference tokenbuf coll external-callback)
593 elseif (or (eq #\' ch) (eq #\" ch)) then
594 (setf value-delim ch)
595 (setf state state-dtd-!-entity-value)
596 elseif (xml-name-start-char-p ch) then
597 (add-to-coll coll ch)
598 (setf state state-dtd-!-entity6)
600 (add-to-coll coll ch)
601 (setq ch (get-next-char tokenbuf))
604 (xml-error (concatenate 'string
605 "illegal DTD <!ENTITY spec: '"
606 (compute-coll-string coll)
609 (#.state-dtd-!-entity6
610 (if* (xml-name-char-p ch) ;; starting char already passed more restrictive test
612 (add-to-coll coll ch)
613 elseif (and external (eq #\% ch)) then
614 (external-param-reference tokenbuf coll external-callback)
616 (when (not (xml-space-p ch))
618 (add-to-coll coll ch)
619 (setq ch (get-next-char tokenbuf))
624 "illegal character in '"
625 (compute-coll-string coll)
626 "' in <! tag: " (string tag-to-return) " "
627 (string (first contents-to-return))
630 (let ((token (compute-tag coll)))
631 (push token contents-to-return)
633 (if* (eq :SYSTEM token) then (setf state state-!-dtd-system)
634 elseif (eq :PUBLIC token) then (setf state state-!-dtd-public)
637 "expected 'SYSTEM' or 'PUBLIC' got '"
638 (string (first contents-to-return))
639 "' in <! tag: " (string tag-to-return) " "
640 (string (second contents-to-return))))
643 (#.state-dtd-!-entity7
644 (if* (xml-space-p ch) then nil
645 elseif (and external (eq #\% ch)) then
646 (external-param-reference tokenbuf coll external-callback)
647 elseif (xml-name-start-char-p ch) then
648 (add-to-coll coll ch)
649 (setf state state-dtd-!-entity3)
651 (add-to-coll coll ch)
652 (setq ch (get-next-char tokenbuf))
655 (xml-error (concatenate 'string
656 "illegal DTD <!ENTITY % name: "
657 (compute-coll-string coll)
660 (#.state-!-dtd-public
661 (if* (xml-space-p ch) then nil
662 elseif (and external (eq #\% ch)) then
663 (external-param-reference tokenbuf coll external-callback)
664 elseif (or (eq #\" ch) (eq #\' ch)) then
665 (setf state state-!-dtd-public2)
666 (setf value-delim ch)
669 "expected quote or double-quote got: '"
671 "' in <! tag: " (string tag-to-return) " "
672 (string (second contents-to-return)) " "
673 (string (first contents-to-return))
675 (#.state-!-dtd-public2
676 (if* (eq value-delim ch) then
677 (push (setf public-string
678 (normalize-public-value
679 (compute-coll-string coll))) contents-to-return)
681 (setf state state-!-dtd-public3)
682 elseif (pub-id-char-p ch) then (add-to-coll coll ch)
684 (add-to-coll coll ch)
685 (setq ch (get-next-char tokenbuf))
690 "illegal character in string: '"
691 (compute-coll-string coll) "'"))
693 (#.state-!-dtd-public3
694 (if* (xml-space-p ch) then (setf state state-!-dtd-system)
695 elseif (and external (eq #\% ch)) then
696 (external-param-reference tokenbuf coll external-callback)
697 elseif (and (not entityp)
699 (setf state state-!-dtd-system)
703 (add-to-coll coll ch)
704 (setq ch (get-next-char tokenbuf))
709 "Expected space before: '"
710 (compute-coll-string coll) "'"))
712 (#.state-!-dtd-system
713 (if* (xml-space-p ch) then nil
714 elseif (and external (eq #\% ch)) then
715 (external-param-reference tokenbuf coll external-callback)
716 elseif (or (eq #\" ch) (eq #\' ch)) then
717 (setf state state-!-dtd-system2)
718 (setf value-delim ch)
719 elseif (and (not entityp)
720 (eq #\> ch)) then (return)
723 "expected quote or double-quote got: '"
725 "' in <! tag: " (string tag-to-return) " "
726 (string (second contents-to-return)) " "
727 (string (first contents-to-return))
729 (#.state-!-dtd-system2
730 (when (not (xml-char-p ch))
731 (xml-error "XML is not well formed")) ;; not tested
732 (if* (eq value-delim ch) then
733 (let ((entity-symbol (first (last contents-to-return)))
734 (system-string (compute-coll-string coll)))
736 (when (not (assoc entity-symbol (iostruct-parameter-entities tokenbuf)))
737 (setf (iostruct-parameter-entities tokenbuf)
738 (acons entity-symbol (list (parse-uri system-string)
741 (iostruct-parameter-entities tokenbuf)))
744 (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
745 (setf (iostruct-general-entities tokenbuf)
746 (acons entity-symbol (list (parse-uri system-string)
750 (iostruct-general-entities tokenbuf)))
751 (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
752 (setf (iostruct-general-entities tokenbuf)
753 (acons entity-symbol (list (parse-uri system-string)
757 (iostruct-general-entities tokenbuf))))
760 (push system-string contents-to-return))
762 (setf state state-!-dtd-system3)
763 else (add-to-coll coll ch)))
764 (#.state-!-dtd-system3
765 (if* (xml-space-p ch) then (setf state state-!-dtd-system4)
766 elseif (and external (eq #\% ch)) then
767 (external-param-reference tokenbuf coll external-callback)
768 elseif (eq #\> ch) then (return)
771 (add-to-coll coll ch)
772 (setq ch (get-next-char tokenbuf))
775 (xml-error (concatenate 'string
776 "illegal DTD <!ENTITY value for "
777 (string (first (nreverse contents-to-return)))
779 (compute-coll-string coll)
782 (#.state-!-dtd-system4
783 (if* (xml-space-p ch) then nil
784 elseif (and external (eq #\% ch)) then
785 (external-param-reference tokenbuf coll external-callback)
786 elseif (and (not pentityp) (xml-name-start-char-p ch)) then
787 (add-to-coll coll ch)
788 (setf state state-!-dtd-system5)
789 elseif (eq #\> ch) then (return)
791 (add-to-coll coll ch)
792 (setq ch (get-next-char tokenbuf))
795 (xml-error (concatenate 'string
796 "illegal DTD <!ENTITY value for "
797 (string (first (nreverse contents-to-return)))
799 (compute-coll-string coll)
802 (#.state-!-dtd-system5
803 (if* (xml-name-char-p ch) then
804 (add-to-coll coll ch)
805 elseif (and external (eq #\% ch)) then
806 (external-param-reference tokenbuf coll external-callback)
807 elseif (xml-space-p ch) then
808 (let ((token (compute-tag coll)))
809 (when (not (eq :NDATA token))
811 (add-to-coll coll ch)
812 (setq ch (get-next-char tokenbuf))
815 (xml-error (concatenate 'string
816 "illegal DTD <!ENTITY value for "
817 (string (first (nreverse contents-to-return)))
819 (compute-coll-string coll)
823 (push token contents-to-return)
824 (setf state state-!-dtd-system6))
826 (add-to-coll coll ch)
827 (setq ch (get-next-char tokenbuf))
830 (xml-error (concatenate 'string
831 "illegal DTD <!ENTITY value for "
832 (string (first (nreverse contents-to-return)))
834 (compute-coll-string coll)
837 (#.state-!-dtd-system6
838 (if* (xml-space-p ch) then nil
839 elseif (and external (eq #\% ch)) then
840 (external-param-reference tokenbuf coll external-callback)
841 elseif (xml-name-start-char-p ch) then
842 (add-to-coll coll ch)
843 (setf state state-!-dtd-system7)
845 (add-to-coll coll ch)
846 (setq ch (get-next-char tokenbuf))
849 (xml-error (concatenate 'string
850 "illegal DTD <!ENTITY value for "
851 (string (first (nreverse contents-to-return)))
853 (compute-coll-string coll)
856 (#.state-!-dtd-system7
857 (if* (xml-name-char-p ch) then
858 (add-to-coll coll ch)
859 elseif (and external (eq #\% ch)) then
860 (external-param-reference tokenbuf coll external-callback)
861 elseif (xml-space-p ch) then
862 (push (compute-tag coll) contents-to-return)
864 (setf state state-dtd-!-entity5) ;; just looking for space, >
865 elseif (eq #\> ch) then
866 (push (compute-tag coll) contents-to-return)
870 (add-to-coll coll ch)
871 (setq ch (get-next-char tokenbuf))
874 (xml-error (concatenate 'string
875 "illegal DTD <!ENTITY value for "
876 (string (first (nreverse contents-to-return)))
878 (compute-coll-string coll)
881 (#.state-dtd-!-entity-value
882 (if* (eq ch value-delim) then
883 (let ((tmp (compute-coll-string coll)))
884 (when (> (length tmp) 0)
885 (when (null (first pending)) (setf pending (rest pending)))
887 (if* (> (length pending) 1) then
888 (push (nreverse pending) contents-to-return)
889 else (push (first pending) contents-to-return))
890 (setf pending (list nil))
891 (setf state state-dtd-!-entity5)
894 (when (not (assoc (third contents-to-return)
895 (iostruct-parameter-entities tokenbuf)))
896 (setf (iostruct-parameter-entities tokenbuf)
897 (acons (third contents-to-return)
898 (first contents-to-return)
899 (iostruct-parameter-entities tokenbuf))))
901 (when (not (assoc (second contents-to-return)
902 (iostruct-general-entities tokenbuf)))
903 (setf (iostruct-general-entities tokenbuf)
904 (acons (second contents-to-return)
905 (first contents-to-return)
906 (iostruct-general-entities tokenbuf)))))
907 elseif (eq #\& ch) then
908 (setf reference-save-state state-dtd-!-entity-value)
909 (setf state state-dtd-!-attdef-decl-value3)
910 elseif (eq #\% ch) then
912 (setf reference-save-state state-dtd-!-entity-value)
913 (setf state state-dtd-!-attdef-decl-value3)
914 elseif (xml-char-p ch)
915 then (add-to-coll coll ch)
917 (add-to-coll coll ch)
918 (setq ch (get-next-char tokenbuf))
921 (xml-error (concatenate 'string
922 "illegal DTD <!ENTITY value for "
923 (string (first contents-to-return))
925 (compute-coll-string coll)
928 (#.state-dtd-!-entity5
929 (if* (xml-space-p ch) then nil
930 elseif (and external (eq #\% ch)) then
931 (external-param-reference tokenbuf coll external-callback)
932 elseif (eq #\> ch) then (return)
933 else (clear-coll coll)
935 (add-to-coll coll ch)
936 (setq ch (get-next-char tokenbuf))
939 (xml-error (concatenate 'string
940 "illegal DTD contents following <!ENTITY spec for "
941 (string (first contents-to-return))
943 (compute-coll-string coll)
946 (#.state-dtd-!-attlist
947 (if* (xml-name-start-char-p ch) then (setf state state-dtd-!-attlist-name)
949 elseif (xml-space-p ch) then nil
950 elseif (and external (eq #\% ch)) then
951 (external-param-reference tokenbuf coll external-callback)
953 (add-to-coll coll ch)
954 (setq ch (get-next-char tokenbuf))
957 (xml-error (concatenate 'string
958 "illegal DTD characters, starting at: '<!ATTLIST "
959 (compute-coll-string coll)
961 (#.state-dtd-!-attlist-name
962 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
963 elseif (and external (eq #\% ch)) then
964 (external-param-reference tokenbuf coll external-callback)
965 elseif (xml-space-p ch) then
966 (push (compute-tag coll *package*)
969 (setf state state-dtd-!-attdef)
970 elseif (eq #\> ch) then
971 (push (compute-tag coll *package*)
975 else (push (compute-tag coll)
979 (add-to-coll coll ch)
980 (setq ch (get-next-char tokenbuf))
983 (xml-error (concatenate 'string
984 "illegal DTD <!ATTLIST content spec for "
985 (string (first contents-to-return))
987 (compute-coll-string coll)
990 (#.state-dtd-!-attdef
991 (if* (xml-space-p ch) then nil
992 elseif (and external (eq #\% ch)) then
993 (external-param-reference tokenbuf coll external-callback)
994 elseif (xml-name-start-char-p ch) then
996 (setf state state-dtd-!-attdef-name)
997 elseif (eq #\> ch) then (return)
999 (add-to-coll coll ch)
1000 (setq ch (get-next-char tokenbuf))
1003 (xml-error (concatenate 'string
1004 "illegal DTD <!ATTLIST content spec for "
1005 (string (first contents-to-return))
1007 (compute-coll-string coll)
1010 (#.state-dtd-!-attdef-name
1011 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1012 elseif (and external (eq #\% ch)) then
1013 (external-param-reference tokenbuf coll external-callback)
1014 elseif (xml-space-p ch) then
1015 (setf (first pending) (compute-tag coll *package*))
1017 (setf state state-dtd-!-attdef-type)
1018 else (dotimes (i 15)
1019 (add-to-coll coll ch)
1020 (setq ch (get-next-char tokenbuf))
1023 (xml-error (concatenate 'string
1024 "illegal DTD <!ATTLIST type spec for "
1025 (string (first contents-to-return))
1027 (compute-coll-string coll)
1030 (#.state-dtd-!-attdef-type
1031 (if* (xml-space-p ch) then nil
1032 elseif (and external (eq #\% ch)) then
1033 (external-param-reference tokenbuf coll external-callback)
1034 else (un-next-char ch)
1035 ;; let next state do all other checking
1036 (setf state state-dtd-!-attdef-type2)))
1037 (#.state-dtd-!-attdef-type2
1038 ;; can only be one of a few tokens, but wait until token built to check
1039 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1040 elseif (and (eq #\( ch) (= 0 (length (compute-coll-string coll)))) then
1041 (push (list :enumeration) pending)
1042 (setf state state-dtd-!-attdef-notation2)
1043 elseif (and external (eq #\% ch)) then
1044 (external-param-reference tokenbuf coll external-callback)
1045 elseif (xml-space-p ch) then
1046 (let ((token (compute-tag coll)))
1047 (when (and (not (eq :CDATA token))
1048 (not (eq :ID token))
1049 (not (eq :IDREF token))
1050 (not (eq :IDREFS token))
1051 (not (eq :ENTITY token))
1052 (not (eq :ENTITIES token))
1053 (not (eq :NMTOKEN token))
1054 (not (eq :NMTOKENS token))
1055 (not (eq :NOTATION token)))
1057 (add-to-coll coll ch)
1058 (setq ch (get-next-char tokenbuf))
1061 (xml-error (concatenate 'string
1062 "illegal DTD <!ATTLIST type spec for "
1063 (string (first contents-to-return))
1065 (compute-coll-string coll)
1067 (if* (eq token :NOTATION) then
1068 (push (list token) pending)
1069 (setf state state-dtd-!-attdef-notation)
1071 (push token pending)
1072 (setf state state-dtd-!-attdef-decl))
1075 else (dotimes (i 15)
1076 (add-to-coll coll ch)
1077 (setq ch (get-next-char tokenbuf))
1080 (xml-error (concatenate 'string
1081 "illegal DTD <!ATTLIST type spec for "
1082 (string (first contents-to-return))
1084 (compute-coll-string coll)
1087 (#.state-dtd-!-attdef-notation
1088 (if* (xml-space-p ch) then nil
1089 elseif (and external (eq #\% ch)) then
1090 (external-param-reference tokenbuf coll external-callback)
1091 elseif (eq #\( ch) then (setf state state-dtd-!-attdef-notation2)
1092 else (dotimes (i 15)
1093 (add-to-coll coll ch)
1094 (setq ch (get-next-char tokenbuf))
1097 (xml-error (concatenate 'string
1098 "illegal DTD <!ATTLIST type spec for "
1099 (string (first contents-to-return))
1101 (compute-coll-string coll)
1104 (#.state-dtd-!-attdef-notation2
1105 (if* (xml-space-p ch) then nil
1106 elseif (and external (eq #\% ch)) then
1107 (external-param-reference tokenbuf coll external-callback)
1108 elseif (xml-name-start-char-p ch) then
1109 (setf state state-dtd-!-attdef-notation3)
1110 (add-to-coll coll ch)
1111 elseif (and (xml-name-char-p ch) (listp (first pending))
1112 (eq :enumeration (first (reverse (first pending))))) then
1113 (setf state state-dtd-!-attdef-notation3)
1114 (add-to-coll coll ch)
1115 else (dotimes (i 15)
1116 (add-to-coll coll ch)
1117 (setq ch (get-next-char tokenbuf))
1120 (xml-error (concatenate 'string
1121 "illegal DTD <!ATTLIST type spec for "
1122 (string (first contents-to-return))
1124 (compute-coll-string coll)
1127 (#.state-dtd-!-attdef-notation3
1128 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1129 elseif (and external (eq #\% ch)) then
1130 (external-param-reference tokenbuf coll external-callback)
1131 elseif (and external (eq #\% ch)) then
1132 (external-param-reference tokenbuf coll external-callback)
1133 elseif (xml-space-p ch) then
1134 (push (compute-tag coll) (first pending))
1136 (setf state state-dtd-!-attdef-notation4)
1137 elseif (eq #\| ch) then
1138 (push (compute-tag coll) (first pending))
1140 (setf state state-dtd-!-attdef-notation2)
1141 elseif (eq #\) ch) then
1142 (push (compute-tag coll) (first pending))
1144 (setf (first pending) (nreverse (first pending)))
1145 ;;(setf state state-dtd-!-attdef-decl)
1146 (setf state state-dtd-!-attdef-notation5)
1147 else (dotimes (i 15)
1148 (add-to-coll coll ch)
1149 (setq ch (get-next-char tokenbuf))
1152 (xml-error (concatenate 'string
1153 "illegal DTD <!ATTLIST type spec for "
1154 (string (first contents-to-return))
1156 (compute-coll-string coll)
1159 (#.state-dtd-!-attdef-notation5
1160 (if* (xml-space-p ch) then (setf state state-dtd-!-attdef-decl)
1161 elseif (and external (eq #\% ch)) then
1162 (external-param-reference tokenbuf coll external-callback)
1165 (add-to-coll coll ch)
1166 (setq ch (get-next-char tokenbuf))
1170 (concatenate 'string
1171 "Expected space before: '"
1172 (compute-coll-string coll) "'"))))
1173 (#.state-dtd-!-attdef-notation4
1174 (if* (xml-space-p ch) then nil
1175 elseif (and external (eq #\% ch)) then
1176 (external-param-reference tokenbuf coll external-callback)
1177 elseif (xml-name-char-p ch) then (add-to-coll coll ch)
1178 (setf state state-dtd-!-attdef-notation3)
1179 elseif (eq #\| ch) then (setf state state-dtd-!-attdef-notation2)
1180 elseif (eq #\) ch) then (setf state state-dtd-!-attdef-decl)
1181 (setf (first pending) (nreverse (first pending)))
1182 else (dotimes (i 15)
1183 (add-to-coll coll ch)
1184 (setq ch (get-next-char tokenbuf))
1187 (xml-error (concatenate 'string
1188 "illegal DTD <!ATTLIST type spec for "
1189 (string (first contents-to-return))
1191 (compute-coll-string coll)
1194 (#.state-dtd-!-attdef-decl
1195 (if* (eq #\# ch) then
1196 (setf state state-dtd-!-attdef-decl-type)
1197 elseif (or (eq #\' ch) (eq #\" ch)) then
1198 (setf value-delim ch)
1199 (setf state state-dtd-!-attdef-decl-value)
1200 elseif (xml-space-p ch) then nil
1201 elseif (and external (eq #\% ch)) then
1202 (external-param-reference tokenbuf coll external-callback)
1203 else (dotimes (i 15)
1204 (add-to-coll coll ch)
1205 (setq ch (get-next-char tokenbuf))
1208 (xml-error (concatenate 'string
1209 "illegal DTD <!ATTLIST type spec for "
1210 (string (first contents-to-return))
1212 (compute-coll-string coll)
1215 (#.state-dtd-!-attdef-decl-value
1216 (if* (eq ch value-delim) then
1218 (push (first (parse-default-value (list (compute-coll-string coll))
1219 tokenbuf external-callback))
1222 (push (compute-coll-string coll) pending)
1223 (setf contents-to-return
1224 (append contents-to-return
1227 else (list (nreverse pending)))))
1228 (setf pending (list nil))
1229 (setf state state-dtd-!-attdef)
1231 elseif (eq #\& ch) then (setf state state-dtd-!-attdef-decl-value3)
1232 (setf reference-save-state state-dtd-!-attdef-decl-value)
1233 elseif (and (xml-char-p ch) (not (eq #\< ch)))
1234 then (add-to-coll coll ch)
1235 else (dotimes (i 15)
1236 (add-to-coll coll ch)
1237 (setq ch (get-next-char tokenbuf))
1240 (xml-error (concatenate 'string
1241 "illegal DTD <!ATTLIST type spec for "
1242 (string (first contents-to-return))
1244 (compute-coll-string coll)
1247 (#.state-dtd-!-attdef-decl-value3
1248 (if* (and (not prefp) (eq #\# ch))
1249 then (setf state state-dtd-!-attdef-decl-value4)
1250 elseif (xml-name-start-char-p ch)
1251 then (setf state state-dtd-!-attdef-decl-value5)
1252 (when (not prefp) (add-to-coll coll #\&))
1254 else (clear-coll coll)
1256 (add-to-coll coll ch)
1257 (setq ch (get-next-char tokenbuf))
1260 (xml-error (concatenate 'string
1261 "illegal reference name, starting at: '&"
1262 (compute-coll-string coll)
1264 (#.state-dtd-!-attdef-decl-value4
1266 then (setf state state-dtd-!-attdef-decl-value6)
1267 elseif (<= (char-code #\0) (char-code ch) (char-code #\9))
1268 then (setf state state-dtd-!-attdef-decl-value7)
1270 else (clear-coll coll)
1272 (add-to-coll coll ch)
1273 (setq ch (get-next-char tokenbuf))
1276 (xml-error (concatenate 'string
1277 "illegal character reference code, starting at: '&#"
1278 (compute-coll-string coll)
1281 (#.state-dtd-!-attdef-decl-value5
1282 (if* (xml-name-char-p ch)
1283 then (add-to-coll entity ch)
1284 (when (not prefp) (add-to-coll coll ch))
1287 (if* (not prefp) then (add-to-coll coll ch)
1288 elseif (not external) then
1290 (concatenate 'string
1291 "internal dtd subset cannot reference parameter entity within a token; entity: "
1292 (compute-coll-string entity)))
1294 (let* ((entity-symbol (compute-tag entity))
1296 (assoc entity-symbol (iostruct-parameter-entities tokenbuf))))
1298 (if* (and (iostruct-do-entity tokenbuf)
1300 (assoc entity-symbol
1301 (iostruct-parameter-entities tokenbuf)))) then
1302 (setf p-value (rest p-value))
1303 (when (member entity-symbol (iostruct-entity-names tokenbuf))
1304 (xml-error (concatenate 'string
1306 (string entity-symbol)
1307 " in recursive reference")))
1308 (push entity-symbol (iostruct-entity-names tokenbuf))
1309 (if* (stringp p-value) then
1310 (dotimes (i (length p-value))
1311 (add-to-coll coll (schar p-value i)))
1313 (if* (null external-callback) then
1314 (setf (iostruct-do-entity tokenbuf) nil)
1316 (let ((count 0) (string "<?xml ") last-ch
1320 (apply external-callback p-value)))
1322 (let ((tmp-buf (get-tokenbuf)))
1323 (setf (tokenbuf-stream tmp-buf)
1326 (iostruct-unget-char tokenbuf))
1327 (setf (iostruct-unget-char tokenbuf) nil)
1328 (unicode-check entity-stream tokenbuf)
1329 (when (iostruct-unget-char tokenbuf)
1330 (setf save-ch (first (iostruct-unget-char tokenbuf))))
1331 (setf (iostruct-unget-char tokenbuf) save-unget)
1342 (iostruct-read-sequence-func
1344 (when (null cch) (return))
1346 (format t "dtd-char: ~s~%" cch))
1347 (if* (< count 0) then
1348 (if* (and (eq last-ch #\?)
1351 else (setf last-ch cch))
1352 elseif (< count 6) then
1353 (when (and (= count 5)
1357 (schar string count)
1360 (when (= tmp-count count)
1366 (add-to-coll coll cch)
1369 elseif (= count 6) then
1371 (add-to-coll coll (schar string i)))
1373 else (add-to-coll coll cch))))
1374 (setf (iostruct-entity-names tokenbuf)
1375 (rest (iostruct-entity-names tokenbuf)))
1376 (close entity-stream)
1377 (put-back-tokenbuf tmp-buf)))))
1379 (setf state state-dtdstart)
1382 (setf state reference-save-state)
1383 else (let ((tmp (compute-coll-string entity)))
1386 (add-to-coll coll ch)
1387 (setq ch (get-next-char tokenbuf))
1390 (xml-error (concatenate 'string
1391 "reference not terminated by ';', starting at: '&"
1393 (compute-coll-string coll)
1396 (#.state-dtd-!-attdef-decl-value6
1397 (let ((code (char-code ch)))
1399 then (add-to-coll coll (code-char char-code))
1401 (setq state state-dtd-!-attdef-decl-value)
1402 elseif (<= (char-code #\0) code (char-code #\9))
1403 then (setf char-code (+ (* char-code 16) (- code (char-code #\0))))
1404 elseif (<= (char-code #\A) code (char-code #\F))
1405 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\A))))
1406 elseif (<= (char-code #\a) code (char-code #\f))
1407 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\a))))
1408 else (clear-coll coll)
1410 (add-to-coll coll ch)
1411 (setq ch (get-next-char tokenbuf))
1414 (xml-error (concatenate 'string
1415 "illegal hexidecimal character reference code, starting at: '"
1416 (compute-coll-string coll)
1417 "', calculated char code: "
1418 (format nil "~s" char-code)))
1420 (#.state-dtd-!-attdef-decl-value7
1421 (let ((code (char-code ch)))
1423 then (add-to-coll coll (code-char char-code))
1425 (setq state reference-save-state)
1426 elseif (<= (char-code #\0) code (char-code #\9))
1427 then (setf char-code (+ (* char-code 10) (- code (char-code #\0))))
1428 else (clear-coll coll)
1430 (add-to-coll coll ch)
1431 (setq ch (get-next-char tokenbuf))
1434 (xml-error (concatenate 'string
1435 "illegal decimal character reference code, starting at: '"
1436 (compute-coll-string coll)
1437 "', calculated char code: "
1438 (format nil "~s" char-code)))
1440 (#.state-dtd-!-attdef-decl-type
1441 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1442 elseif (and external (eq #\% ch)) then
1443 (external-param-reference tokenbuf coll external-callback)
1444 elseif (or (xml-space-p ch) (eq #\> ch)) then
1445 (let ((token (compute-tag coll)))
1446 (when (and (not (eq :REQUIRED token))
1447 (not (eq :IMPLIED token))
1448 (not (eq :FIXED token)))
1450 (add-to-coll coll ch)
1451 (setq ch (get-next-char tokenbuf))
1454 (xml-error (concatenate 'string
1455 "illegal DTD <!ATTLIST type spec for "
1456 (string (first contents-to-return))
1458 (compute-coll-string coll)
1460 (push token pending)
1461 (if* (eq :FIXED token) then
1464 (add-to-coll coll ch)
1465 (setq ch (get-next-char tokenbuf))
1468 (xml-error (concatenate 'string
1469 "illegal DTD <!ATTLIST type spec for "
1470 (string (first contents-to-return))
1472 (compute-coll-string coll)
1474 (setf state state-dtd-!-attdef-decl-value2)
1475 elseif (eq #\> ch) then
1476 (setf contents-to-return
1477 (append contents-to-return (list (nreverse pending))))
1479 else (setf contents-to-return
1480 (append contents-to-return (list (nreverse pending))))
1481 (setf pending (list nil))
1482 (setf state state-dtd-!-attdef)))
1484 else (dotimes (i 15)
1485 (add-to-coll coll ch)
1486 (setq ch (get-next-char tokenbuf))
1489 (xml-error (concatenate 'string
1490 "illegal DTD <!ATTLIST type spec for "
1491 (string (first contents-to-return))
1493 (compute-coll-string coll)
1496 (#. state-dtd-!-attdef-decl-value2
1497 (if* (xml-space-p ch) then nil
1498 elseif (and external (eq #\% ch)) then
1499 (external-param-reference tokenbuf coll external-callback)
1500 elseif (or (eq #\' ch) (eq #\" ch)) then
1501 (setf value-delim ch)
1502 (setf state state-dtd-!-attdef-decl-value)
1503 else (dotimes (i 15)
1504 (add-to-coll coll ch)
1505 (setq ch (get-next-char tokenbuf))
1508 (xml-error (concatenate 'string
1509 "illegal DTD <!ATTLIST type spec for "
1510 (string (first contents-to-return))
1512 (compute-coll-string coll)
1515 (#.state-dtd-!-element
1516 (if* (xml-space-p ch) then nil
1517 elseif (and external (eq #\% ch)) then
1518 (external-param-reference tokenbuf coll external-callback)
1519 elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-element-name)
1521 else (dotimes (i 15)
1522 (add-to-coll coll ch)
1523 (setq ch (get-next-char tokenbuf))
1526 (xml-error (concatenate 'string
1527 "illegal DTD characters, starting at: '<!ELEMENT "
1528 (compute-coll-string coll)
1530 (#.state-dtd-!-element-name
1531 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1532 elseif (and external (eq #\% ch)) then
1533 (external-param-reference tokenbuf coll external-callback)
1534 elseif (xml-space-p ch) then
1535 (push (compute-tag coll)
1538 (setf state state-dtd-!-element-type)
1539 else (dotimes (i 15)
1540 (add-to-coll coll ch)
1541 (setq ch (get-next-char tokenbuf))
1544 (xml-error (concatenate 'string
1545 "illegal DTD <!ELEMENT name: '"
1546 (compute-coll-string coll)
1549 (#.state-dtd-!-element-type
1550 (if* (eq #\( ch) then (setf state state-dtd-!-element-type-paren)
1551 elseif (xml-space-p ch) then nil
1552 elseif (and external (eq #\% ch)) then
1553 (external-param-reference tokenbuf coll external-callback)
1554 elseif (xml-name-start-char-p ch) then
1556 (setf state state-dtd-!-element-type-token)
1557 else (dotimes (i 15)
1558 (add-to-coll coll ch)
1559 (setq ch (get-next-char tokenbuf))
1562 (xml-error (concatenate 'string
1563 "illegal DTD <!ELEMENT content spec for "
1564 (string (first contents-to-return))
1566 (compute-coll-string coll)
1569 (#.state-dtd-!-element-type-paren
1570 (if* (xml-space-p ch) then nil
1571 elseif (and external (eq #\% ch)) then
1572 (external-param-reference tokenbuf coll external-callback)
1573 elseif (xml-name-start-char-p ch) then
1575 (setf state state-dtd-!-element-type-paren-name)
1576 elseif (eq #\# ch) then
1577 (setf state state-dtd-!-element-type-paren-pcd)
1578 elseif (eq #\( ch) then
1580 (setf state state-dtd-!-element-type-paren-choice-paren)
1581 else (dotimes (i 15)
1582 (add-to-coll coll ch)
1583 (setq ch (get-next-char tokenbuf))
1586 (xml-error (concatenate 'string
1587 "illegal DTD <!ELEMENT content spec for "
1588 (string (first contents-to-return))
1590 (compute-coll-string coll)
1592 (#.state-dtd-!-element-type-paren2
1593 (if* (eq #\> ch) then
1594 ;; there only one name...
1595 (setf (first contents-to-return) (first (first contents-to-return)))
1597 elseif (eq #\* ch) then
1598 (setf state state-dtd-!-element-type-paren-pcd5)
1599 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1600 (if* (> (length (first contents-to-return)) 1) then
1601 (setf (first contents-to-return)
1602 (list (append (list :choice)
1603 (first contents-to-return))))
1604 elseif (listp (first (first contents-to-return))) then
1605 (setf (first contents-to-return)
1606 (first (first contents-to-return))))
1607 (push :* (first contents-to-return))
1608 elseif (eq #\? ch) then
1609 (setf state state-dtd-!-element-type-paren-pcd5)
1610 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1611 (if* (> (length (first contents-to-return)) 1) then
1612 (setf (first contents-to-return)
1613 (list (append (list :choice)
1614 (first contents-to-return))))
1615 elseif (listp (first (first contents-to-return))) then
1616 (setf (first contents-to-return)
1617 (first (first contents-to-return))))
1618 (push :? (first contents-to-return))
1619 elseif (eq #\+ ch) then
1620 (setf state state-dtd-!-element-type-paren-pcd5)
1621 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1622 (if* (> (length (first contents-to-return)) 1) then
1623 (setf (first contents-to-return)
1624 (list (append (list :choice)
1625 (first contents-to-return))))
1626 elseif (listp (first (first contents-to-return))) then
1627 (setf (first contents-to-return)
1628 (first (first contents-to-return))))
1629 (push :+ (first contents-to-return))
1630 elseif (and external (eq #\% ch)) then
1631 (external-param-reference tokenbuf coll external-callback)
1632 elseif (xml-space-p ch) then
1633 (setf state state-dtd-!-element-type-paren-pcd5)
1634 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1635 (when (> (length (first contents-to-return)) 1)
1636 (setf (first contents-to-return)
1637 (list (append (list :\choice)
1638 (first contents-to-return)))))
1639 else (dotimes (i 15)
1640 (add-to-coll coll ch)
1641 (setq ch (get-next-char tokenbuf))
1644 (xml-error (concatenate 'string
1645 "illegal DTD <!ELEMENT content spec for "
1646 (string (first (reverse contents-to-return)))
1648 (compute-coll-string coll)
1651 (#.state-dtd-!-element-type-paren-name
1652 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1653 elseif (and external (eq #\% ch)) then
1654 (external-param-reference tokenbuf coll external-callback)
1655 elseif (xml-space-p ch) then
1656 (push (compute-tag coll) (first pending))
1658 (setf state state-dtd-!-element-type-paren-name2)
1659 elseif (eq #\? ch) then
1660 (push (compute-tag coll) (first pending))
1661 (setf (first pending)
1662 (list (push :? (first pending))))
1664 (setf state state-dtd-!-element-type-paren-name2)
1665 elseif (eq #\* ch) then
1666 (push (compute-tag coll) (first pending))
1667 (setf (first pending)
1668 (list (push :* (first pending))))
1670 (setf state state-dtd-!-element-type-paren-name2)
1671 elseif (eq #\+ ch) then
1672 (push (compute-tag coll) (first pending))
1673 (setf (first pending)
1674 (list (push :+ (first pending))))
1676 (setf state state-dtd-!-element-type-paren-name2)
1677 elseif (eq #\) ch) then
1678 (push (compute-tag coll) (first pending))
1680 (if* (= (length pending) 1) then
1681 (push (first pending) contents-to-return)
1682 (setf state state-dtd-!-element-type-paren2)
1683 else ;; this is (xxx)
1684 (if* (second pending) then
1685 (push (first pending) (second pending))
1686 else (setf (second pending) (first pending)))
1687 (setf pending (rest pending))
1688 (setf state state-dtd-!-element-type-paren-choice-name3)
1690 elseif (eq #\, ch) then
1691 (when (and (first pending) (not (eq :seq (first pending-type))))
1694 (add-to-coll coll ch)
1695 (setq ch (get-next-char tokenbuf))
1698 (xml-error (concatenate 'string
1699 "illegal '|' and ',' mix starting at '"
1700 (compute-coll-string coll)
1702 (push (compute-tag coll) (first pending))
1703 (push :seq pending-type)
1705 (setf state state-dtd-!-element-type-paren-choice)
1706 elseif (eq #\| ch) then
1707 (when (and (first pending) (not (eq :choice (first pending-type))))
1710 (add-to-coll coll ch)
1711 (setq ch (get-next-char tokenbuf))
1714 (xml-error (concatenate 'string
1715 "illegal '|' and ',' mix starting at '"
1716 (compute-coll-string coll)
1718 (push (compute-tag coll) (first pending))
1719 (push :choice pending-type)
1721 (setf state state-dtd-!-element-type-paren-choice)
1722 else (dotimes (i 15)
1723 (add-to-coll coll ch)
1724 (setq ch (get-next-char tokenbuf))
1727 (xml-error (concatenate 'string
1728 "illegal DTD <!ELEMENT content spec for "
1729 (string (first contents-to-return))
1731 (compute-coll-string coll)
1734 (#.state-dtd-!-element-type-paren-name2
1735 (if* (xml-space-p ch) then nil
1736 elseif (and external (eq #\% ch)) then
1737 (external-param-reference tokenbuf coll external-callback)
1738 elseif (eq #\| ch) then
1739 (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
1742 (add-to-coll coll ch)
1743 (setq ch (get-next-char tokenbuf))
1746 (xml-error (concatenate 'string
1747 "illegal '|' and ',' mix starting at '"
1748 (compute-coll-string coll)
1750 (push :choice pending-type)
1751 (setf state state-dtd-!-element-type-paren-choice)
1752 elseif (eq #\, ch) then
1753 (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
1756 (add-to-coll coll ch)
1757 (setq ch (get-next-char tokenbuf))
1760 (xml-error (concatenate 'string
1761 "illegal '|' and ',' mix starting at '"
1762 (compute-coll-string coll)
1764 (push :seq pending-type)
1765 (setf state state-dtd-!-element-type-paren-choice)
1766 elseif (eq #\) ch) then
1767 (if* (= (length pending) 1) then
1768 (push (list (first pending)) contents-to-return)
1769 (setf state state-dtd-!-element-type-paren2)
1770 else (setf pending (reverse (rest (reverse pending))))
1772 else (dotimes (i 15)
1773 (add-to-coll coll ch)
1774 (setq ch (get-next-char tokenbuf))
1777 (xml-error (concatenate 'string
1778 "illegal DTD <!ELEMENT content spec for "
1779 (string (first (reverse contents-to-return)))
1781 (compute-coll-string coll)
1785 (#.state-dtd-!-element-type-paren-choice
1786 (if* (xml-name-start-char-p ch) then
1788 (setf state state-dtd-!-element-type-paren-choice-name)
1789 elseif (xml-space-p ch) then nil
1790 elseif (and external (eq #\% ch)) then
1791 (external-param-reference tokenbuf coll external-callback)
1792 elseif (eq #\( ch) then
1794 (setf state state-dtd-!-element-type-paren-choice-paren)
1795 elseif (eq #\) ch) then
1796 (if* (= (length pending) 1) then
1797 (setf (first pending) (nreverse (first pending)))
1798 (if* (> (length (first pending)) 1) then
1799 (push (first pending-type) (first pending))
1800 (setf pending-type (rest pending-type))
1801 else (setf (first pending) (first (first pending))))
1802 (push (first pending) contents-to-return)
1803 (setf state state-dtd-!-element-type-paren3)
1804 else (setf (first pending) (nreverse (first pending)))
1805 (if* (> (length (first pending)) 1) then
1806 (push (first pending-type) (first pending))
1807 (setf pending-type (rest pending-type))
1808 else (setf (first pending) (first (first pending))))
1809 (if* (second pending) then
1810 (push (first pending) (second pending))
1811 else (setf (second pending) (list (first pending))))
1812 (setf pending (rest pending))
1813 (setf state state-dtd-!-element-type-paren-choice-name3)
1815 else (dotimes (i 15)
1816 (add-to-coll coll ch)
1817 (setq ch (get-next-char tokenbuf))
1820 (xml-error (concatenate 'string
1821 "illegal DTD <!ELEMENT content spec for "
1822 (string (first (reverse contents-to-return)))
1824 (compute-coll-string coll)
1828 (#.state-dtd-!-element-type-paren-choice-paren
1829 (if* (xml-name-start-char-p ch) then
1830 (setf state state-dtd-!-element-type-paren-name)
1832 elseif (eq #\( ch) then (push nil pending)
1833 elseif (xml-space-p ch) then nil
1834 elseif (and external (eq #\% ch)) then
1835 (external-param-reference tokenbuf coll external-callback)
1836 else (dotimes (i 15)
1837 (add-to-coll coll ch)
1838 (setq ch (get-next-char tokenbuf))
1841 (xml-error (concatenate 'string
1842 "illegal DTD <!ELEMENT content spec for "
1843 (string (first contents-to-return))
1845 (compute-coll-string coll)
1848 (#.state-dtd-!-element-type-paren-choice-name
1849 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1850 elseif (and external (eq #\% ch)) then
1851 (external-param-reference tokenbuf coll external-callback)
1852 elseif (xml-space-p ch) then
1853 (push (compute-tag coll) (first pending))
1855 (setf state state-dtd-!-element-type-paren-choice-name2)
1856 elseif (eq #\? ch) then
1857 (push (list :? (compute-tag coll)) (first pending))
1859 (setf state state-dtd-!-element-type-paren-choice-name2)
1860 elseif (eq #\* ch) then
1861 (push (list :* (compute-tag coll)) (first pending))
1863 (setf state state-dtd-!-element-type-paren-choice-name2)
1864 elseif (eq #\+ ch) then
1865 (push (list :+ (compute-tag coll)) (first pending))
1867 (setf state state-dtd-!-element-type-paren-choice-name2)
1868 elseif (eq #\) ch) then
1869 (push (compute-tag coll) (first pending))
1871 (if* (= (length pending) 1) then
1872 (setf (first pending) (nreverse (first pending)))
1873 (if* (> (length (first pending)) 1) then
1874 (push (first pending-type) (first pending))
1875 (setf pending-type (rest pending-type))
1876 else (setf (first pending) (first (first pending))))
1877 (push (first pending) contents-to-return)
1878 (setf state state-dtd-!-element-type-paren3)
1879 else (setf (first pending) (nreverse (first pending)))
1880 (push (first pending-type) (first pending))
1881 (setf pending-type (rest pending-type))
1882 (if* (second pending) then
1883 (push (first pending) (second pending))
1884 else (setf (second pending)
1885 ;; (list (first pending)) ;2001-03-22
1886 (first pending) ;2001-03-22
1888 (setf pending (rest pending))
1889 (setf state state-dtd-!-element-type-paren-choice-name3)
1891 elseif (eq #\, ch) then
1892 (when (and (first pending) (not (eq :seq (first pending-type))))
1895 (add-to-coll coll ch)
1896 (setq ch (get-next-char tokenbuf))
1899 (xml-error (concatenate 'string
1900 "illegal '|' and ',' mix starting at '"
1901 (compute-coll-string coll)
1903 (push (compute-tag coll) (first pending))
1905 (push :seq pending-type)
1906 (setf state state-dtd-!-element-type-paren-choice)
1907 elseif (eq #\| ch) then
1908 (when (and (first pending) (not (eq :choice (first pending-type))))
1911 (add-to-coll coll ch)
1912 (setq ch (get-next-char tokenbuf))
1915 (xml-error (concatenate 'string
1916 "illegal '|' and ',' mix starting at '"
1917 (compute-coll-string coll)
1919 (push (compute-tag coll) (first pending))
1921 (push :choice pending-type)
1922 (setf state state-dtd-!-element-type-paren-choice)
1923 else (dotimes (i 15)
1924 (add-to-coll coll ch)
1925 (setq ch (get-next-char tokenbuf))
1928 (xml-error (concatenate 'string
1929 "illegal DTD <!ELEMENT content spec for "
1930 (string (first contents-to-return))
1932 (compute-coll-string coll)
1935 (#.state-dtd-!-element-type-paren-choice-name2
1937 ;; begin changes 2001-03-22
1938 then (setf state state-dtd-!-element-type-paren-choice)
1939 (push :choice pending-type)
1941 then (setf state state-dtd-!-element-type-paren-choice)
1942 (push :seq pending-type)
1943 ;; end changes 2001-03-22
1944 elseif (xml-space-p ch) then nil
1945 elseif (and external (eq #\% ch)) then
1946 (external-param-reference tokenbuf coll external-callback)
1947 elseif (eq #\) ch) then
1948 (if* (= (length pending) 1) then
1949 (setf (first pending) (nreverse (first pending)))
1950 (if* (> (length (first pending)) 1) then
1951 (push (first pending-type) (first pending))
1952 (setf pending-type (rest pending-type))
1953 else (setf (first pending) (first (first pending))))
1954 (push (first pending) contents-to-return)
1955 (setf state state-dtd-!-element-type-paren3)
1956 else (setf (first pending) (nreverse (first pending)))
1957 (push (first pending-type) (first pending))
1958 (setf pending-type (rest pending-type))
1959 (if* (second pending) then
1960 (push (first pending) (second pending))
1961 else (setf (second pending) (list (first pending))))
1962 (setf state state-dtd-!-element-type-paren-choice-name3)
1964 (setf pending (rest pending))
1965 else (dotimes (i 15)
1966 (add-to-coll coll ch)
1967 (setq ch (get-next-char tokenbuf))
1970 (xml-error (concatenate 'string
1971 "illegal DTD <!ELEMENT content spec for "
1972 (string (first contents-to-return))
1974 (compute-coll-string coll)
1977 (#.state-dtd-!-element-type-paren-choice-name3
1978 (if* (xml-space-p ch) then nil
1979 elseif (and external (eq #\% ch)) then
1980 (external-param-reference tokenbuf coll external-callback)
1981 elseif (eq #\? ch) then
1982 (setf (first pending) (list :? (first pending)))
1983 (setf state state-dtd-!-element-type-paren-choice-name2)
1984 elseif (eq #\* ch) then
1985 (setf (first pending) (list :* (first pending)))
1986 (setf state state-dtd-!-element-type-paren-choice-name2)
1987 elseif (eq #\+ ch) then
1988 (setf (first pending) (list :+ (first pending)))
1989 (setf state state-dtd-!-element-type-paren-choice-name2)
1990 elseif (eq #\) ch) then
1991 (if* (= (length pending) 1) then
1992 (setf (first pending) (nreverse (first pending)))
1993 (if* (> (length (first pending)) 1) then
1994 (push (first pending-type) (first pending))
1995 (setf pending-type (rest pending-type))
1996 else (setf (first pending) (first (first pending))))
1997 (push (first pending) contents-to-return)
1998 (setf pending (rest pending))
1999 (setf state state-dtd-!-element-type-paren3)
2000 else (setf (first pending) (nreverse (first pending)))
2001 (if* (> (length (first pending)) 1) then
2002 (push (first pending-type) (first pending))
2003 (setf pending-type (rest pending-type))
2004 else (setf (first pending) (first (first pending))))
2005 (if* (second pending) then
2006 (push (first pending) (second pending))
2007 else (setf (second pending) (list (first pending))))
2008 (setf pending (rest pending))
2009 (setf state state-dtd-!-element-type-paren-choice)
2011 elseif (eq #\, ch) then
2012 (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
2015 (add-to-coll coll ch)
2016 (setq ch (get-next-char tokenbuf))
2019 (xml-error (concatenate 'string
2020 "illegal '|' and ',' mix starting at '"
2021 (compute-coll-string coll)
2023 (push :seq pending-type)
2024 (setf state state-dtd-!-element-type-paren-choice)
2025 elseif (eq #\| ch) then
2026 (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
2029 (add-to-coll coll ch)
2030 (setq ch (get-next-char tokenbuf))
2033 (xml-error (concatenate 'string
2034 "illegal '|' and ',' mix starting at '"
2035 (compute-coll-string coll)
2037 (push :choice pending-type)
2038 (setf state state-dtd-!-element-type-paren-choice)
2039 else (dotimes (i 15)
2040 (add-to-coll coll ch)
2041 (setq ch (get-next-char tokenbuf))
2044 (xml-error (concatenate 'string
2045 "illegal DTD <!ELEMENT content spec for "
2046 (string (first contents-to-return))
2048 (compute-coll-string coll)
2051 (#.state-dtd-!-element-type-paren3
2052 (if* (eq #\+ ch) then
2053 (setf (first contents-to-return)
2054 (append (list :+) (list (first contents-to-return))))
2055 (setf state state-dtd-!-element-type-paren-pcd5)
2056 elseif (eq #\? ch) then
2057 (setf (first contents-to-return)
2058 (append (list :?) (list (first contents-to-return))))
2059 (setf state state-dtd-!-element-type-paren-pcd5)
2060 elseif (eq #\* ch) then
2061 (setf (first contents-to-return)
2062 (append (list :*) (list (first contents-to-return))))
2063 (setf state state-dtd-!-element-type-paren-pcd5)
2064 elseif (and external (eq #\% ch)) then
2065 (external-param-reference tokenbuf coll external-callback)
2066 elseif (xml-space-p ch) then
2067 (setf state state-dtd-!-element-type-paren-pcd5)
2068 elseif (eq #\> ch) then (return)
2069 else (dotimes (i 15)
2070 (add-to-coll coll ch)
2071 (setq ch (get-next-char tokenbuf))
2074 (xml-error (concatenate 'string
2075 "illegal DTD <!ELEMENT content spec for "
2076 (string (first (reverse contents-to-return)))
2078 (compute-coll-string coll)
2081 (#.state-dtd-!-element-type-paren-pcd
2082 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2083 elseif (and external (eq #\% ch)) then
2084 (external-param-reference tokenbuf coll external-callback)
2085 elseif (xml-space-p ch) then
2086 (let ((token (compute-tag coll)))
2087 (when (not (eq token :PCDATA))
2088 (xml-error (concatenate 'string
2089 "illegal DTD <!ELEMENT content spec for "
2090 (string (first contents-to-return))
2092 (compute-coll-string coll)
2095 (push token contents-to-return))
2096 (setf state state-dtd-!-element-type-paren-pcd2)
2097 elseif (eq #\| ch) then
2098 (let ((token (compute-tag coll)))
2099 (when (not (eq token :PCDATA))
2100 (xml-error (concatenate 'string
2101 "illegal DTD <!ELEMENT content spec for "
2102 (string (first contents-to-return))
2104 (compute-coll-string coll)
2106 (push token contents-to-return))
2108 (setf state state-dtd-!-element-type-paren-pcd3)
2109 elseif (eq #\) ch) then
2110 (let ((token (compute-tag coll)))
2111 (when (not (eq token :PCDATA))
2112 (xml-error (concatenate 'string
2113 "illegal DTD <!ELEMENT content spec for "
2114 (string (first contents-to-return))
2116 (compute-coll-string coll)
2118 (push token contents-to-return))
2119 (setf state state-dtd-!-element-type-paren-pcd4)
2120 else (dotimes (i 15)
2121 (add-to-coll coll ch)
2122 (setq ch (get-next-char tokenbuf))
2125 (xml-error (concatenate 'string
2126 "illegal DTD <!ELEMENT content spec for "
2127 (string (first contents-to-return))
2129 (compute-coll-string coll)
2132 (#.state-dtd-!-element-type-paren-pcd2
2133 (if* (xml-space-p ch) then nil
2134 elseif (and external (eq #\% ch)) then
2135 (external-param-reference tokenbuf coll external-callback)
2136 elseif (eq #\) ch) then
2137 (setf state state-dtd-!-element-type-paren-pcd4)
2138 elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2139 else (dotimes (i 15)
2140 (add-to-coll coll ch)
2141 (setq ch (get-next-char tokenbuf))
2144 (xml-error (concatenate 'string
2145 "illegal DTD <!ELEMENT content spec for "
2146 (string (first (reverse contents-to-return)))
2148 (compute-coll-string coll)
2151 (#.state-dtd-!-element-type-paren-pcd3
2152 (if* (xml-space-p ch) then nil
2153 elseif (and external (eq #\% ch)) then
2154 (external-param-reference tokenbuf coll external-callback)
2155 elseif (xml-name-start-char-p ch) then
2157 (setf state state-dtd-!-element-type-paren-pcd7)
2158 else (dotimes (i 15)
2159 (add-to-coll coll ch)
2160 (setq ch (get-next-char tokenbuf))
2163 (xml-error (concatenate 'string
2164 "illegal DTD <!ELEMENT content spec for "
2165 (string (first (reverse contents-to-return)))
2167 (compute-coll-string coll)
2170 (#.state-dtd-!-element-type-paren-pcd4
2171 (if* (xml-space-p ch) then
2172 (setf state state-dtd-!-element-type-paren-pcd6)
2173 elseif (and external (eq #\% ch)) then
2174 (external-param-reference tokenbuf coll external-callback)
2175 elseif (eq #\* ch) then
2176 (setf (first contents-to-return) '(:* :PCDATA))
2177 (setf state state-dtd-!-element-type-paren-pcd5)
2178 elseif (eq #\> ch) then (return)
2179 else (clear-coll coll)
2181 (add-to-coll coll ch)
2182 (setq ch (get-next-char tokenbuf))
2185 (xml-error (concatenate 'string
2186 "illegal DTD contents following <!ELEMENT content spec for "
2187 (string (first (reverse contents-to-return)))
2189 (compute-coll-string coll)
2192 (#.state-dtd-!-element-type-paren-pcd5
2193 (if* (xml-space-p ch) then nil
2194 elseif (and external (eq #\% ch)) then
2195 (external-param-reference tokenbuf coll external-callback)
2196 elseif (eq #\> ch) then (return)
2197 else (clear-coll coll)
2199 (add-to-coll coll ch)
2200 (setq ch (get-next-char tokenbuf))
2203 (xml-error (concatenate 'string
2204 "illegal DTD contents following <!ELEMENT content spec for "
2205 (string (first (reverse contents-to-return)))
2207 (compute-coll-string coll)
2210 (#.state-dtd-!-element-type-paren-pcd6
2211 (if* (xml-space-p ch) then nil
2212 elseif (and external (eq #\% ch)) then
2213 (external-param-reference tokenbuf coll external-callback)
2214 elseif (eq #\> ch) then (return)
2215 else (clear-coll coll)
2217 (add-to-coll coll ch)
2218 (setq ch (get-next-char tokenbuf))
2221 (xml-error (concatenate 'string
2222 "illegal DTD contents following <!ELEMENT content spec for "
2223 (string (first (reverse contents-to-return)))
2225 (compute-coll-string coll)
2228 (#.state-dtd-!-element-type-paren-pcd7
2229 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2230 elseif (and external (eq #\% ch)) then
2231 (external-param-reference tokenbuf coll external-callback)
2232 elseif (xml-space-p ch) then
2233 (setf state state-dtd-!-element-type-paren-pcd8)
2234 (let ((token (compute-tag coll)))
2236 (if* (listp (first contents-to-return)) then
2237 (push token (first contents-to-return))
2238 else (setf (first contents-to-return)
2239 (list token (first contents-to-return)))))
2240 elseif (eq #\) ch) then
2241 (setf state state-dtd-!-element-type-paren-pcd9)
2242 (let ((token (compute-tag coll)))
2244 (if* (listp (first contents-to-return)) then
2245 (push token (first contents-to-return))
2246 else (setf (first contents-to-return)
2247 (list token (first contents-to-return)))))
2248 else (clear-coll coll)
2250 (add-to-coll coll ch)
2251 (setq ch (get-next-char tokenbuf))
2254 (xml-error (concatenate 'string
2255 "illegal DTD contents in <!ELEMENT content spec for "
2256 (string (first (reverse contents-to-return)))
2258 (compute-coll-string coll)
2261 (#.state-dtd-!-element-type-paren-pcd8
2262 (if* (xml-space-p ch) then nil
2263 elseif (and external (eq #\% ch)) then
2264 (external-param-reference tokenbuf coll external-callback)
2265 elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2266 elseif (eq #\) ch) then (setf state state-dtd-!-element-type-paren-pcd9)
2267 else (clear-coll coll)
2269 (add-to-coll coll ch)
2270 (setq ch (get-next-char tokenbuf))
2273 (xml-error (concatenate 'string
2274 "illegal DTD contents in <!ELEMENT content spec for "
2275 (string (first (reverse contents-to-return)))
2277 (compute-coll-string coll)
2280 (#.state-dtd-!-element-type-paren-pcd9
2281 (if* (eq #\* ch) then (setf state state-dtd-!-element-type-paren-pcd5)
2282 (setf (first contents-to-return) (nreverse (first contents-to-return)))
2283 (when (> (length (first contents-to-return)) 1)
2284 (setf (first contents-to-return)
2285 (list (append (list :choice)
2286 (first contents-to-return)))))
2287 (push :* (first contents-to-return))
2288 else (clear-coll coll)
2290 (add-to-coll coll ch)
2291 (setq ch (get-next-char tokenbuf))
2294 (xml-error (concatenate 'string
2295 "illegal DTD contents in <!ELEMENT content spec for "
2296 (string (first (reverse contents-to-return)))
2298 (compute-coll-string coll)
2301 (#.state-dtd-!-element-type-token
2302 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2303 elseif (and external (eq #\% ch)) then
2304 (external-param-reference tokenbuf coll external-callback)
2305 elseif (xml-space-p ch) then
2306 (let ((token (compute-tag coll)))
2307 (when (not (or (eq token :EMPTY) (eq token :ANY)))
2308 (xml-error (concatenate 'string
2309 "illegal DTD <!ELEMENT content spec for "
2310 (string (first contents-to-return))
2312 (compute-coll-string coll)
2314 (push token contents-to-return)
2315 (setf state state-dtd-!-element-type-end))
2316 elseif (eq #\> ch) then
2317 (let ((token (compute-tag coll)))
2318 (when (not (or (eq token :EMPTY) (eq token :ANY)))
2319 (xml-error (concatenate 'string
2320 "illegal DTD <!ELEMENT content spec for "
2321 (string (first contents-to-return))
2323 (compute-coll-string coll)
2325 (push token contents-to-return)
2327 else (add-to-coll coll ch)
2328 (xml-error (concatenate 'string
2329 "illegal DTD <!ELEMENT content spec for "
2330 (string (first contents-to-return))
2332 (compute-coll-string coll)
2336 (#.state-dtd-!-element-type-end
2337 (if* (xml-space-p ch) then nil
2338 elseif (and external (eq #\% ch)) then
2339 (external-param-reference tokenbuf coll external-callback)
2340 elseif (eq #\> ch) then (return)
2341 else (xml-error (concatenate 'string
2342 "expected '>', got '"
2344 "' in DTD <! ELEMENT "
2345 (string (first contents-to-return))
2347 (string (second contents-to-return))))
2350 (error "need to support dtd state:~s" state))))
2351 (put-back-collector entity)
2352 (put-back-collector coll)
2355 (when (and (null ch) (not external))
2356 (xml-error "unexpected end of input while parsing DTD"))
2357 (if* (null tag-to-return) then (values nil :end-dtd)
2358 else (error "process other return state")))
2359 ((#.state-dtd-!-element-type-end #.state-dtd-!-element-type-token
2360 #.state-dtd-!-element-type-paren-pcd4 #.state-dtd-!-element-type-paren-pcd6
2361 #.state-dtd-!-element-type-paren-pcd5 #.state-dtd-!-element-type-paren2
2362 #.state-dtd-!-element-type-paren3)
2363 (values (append (list tag-to-return) (nreverse contents-to-return))
2365 ((#.state-dtd-!-attdef-decl-type #.state-dtd-!-attlist-name
2366 #.state-dtd-!-attdef)
2367 (values (append (list tag-to-return) contents-to-return)
2369 ((#.state-dtd-!-entity5 #.state-!-dtd-system3
2370 #.state-!-dtd-system7 #.state-!-dtd-system4
2371 #.state-!-dtd-system ;; this is actually a !NOTATION
2372 #.state-dtd-?-4 ;; PI
2373 #.state-dtd-comment4 ;; comment
2375 (let ((ret (append (list tag-to-return) (nreverse contents-to-return))))
2380 (values (nreverse contents-to-return) nil))
2381 (#.state-dtd-!-include2
2382 (values nil :include))
2383 (#.state-dtd-!-include4
2384 (values nil :include-end))
2385 (#.state-dtd-!-ignore7
2386 (values nil :ignore))
2388 (if* (not external) then
2389 (xml-error "unexpected end of input while processing DTD internal subset")
2390 elseif (or (> include-count 0) (not (eq prev-state state-dtdstart))) then
2391 (xml-error "unexpected end of input while processing external DTD"))
2392 (values nil :end-dtd))
2394 (print (list tag-to-return contents-to-return))
2395 (error "need to support dtd <post> state:~s" state)))
2399 (defun external-param-reference (tokenbuf old-coll external-callback)
2400 (declare (:fbound next-token) (ignorable old-coll) (optimize (speed 3) (safety 1)))
2401 (setf (iostruct-seen-parameter-reference tokenbuf) t)
2402 (macrolet ((add-to-entity-buf (entity-symbol p-value)
2404 (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
2405 (iostruct-entity-bufs tokenbuf))))
2407 `(setf (collector-next ,coll) 0))
2409 `(push ,ch (iostruct-unget-char tokenbuf)))
2410 (add-to-coll (coll ch)
2411 `(let ((.next. (collector-next ,coll)))
2412 (if* (>= .next. (collector-max ,coll))
2413 then (grow-and-add ,coll ,ch)
2414 else (setf (schar (collector-data ,coll) .next.)
2416 (setf (collector-next ,coll) (1+ .next.))))))
2417 (let ((ch (get-next-char tokenbuf))
2418 (coll (get-collector))
2419 p-value entity-symbol)
2420 (add-to-coll coll ch)
2421 (when (not (xml-name-start-char-p ch))
2423 (add-to-coll coll ch)
2424 (setq ch (get-next-char tokenbuf))
2427 (xml-error (concatenate 'string
2428 "Illegal DTD parameter entity name starting at: "
2429 (compute-coll-string coll))))
2431 (setf ch (get-next-char tokenbuf))
2432 (if* (eq #\; ch) then
2433 (setf entity-symbol (compute-tag coll))
2435 #+ignore (format t "entity symbol: ~s entities: ~s match: ~s~%"
2436 entity-symbol (iostruct-parameter-entities tokenbuf)
2437 (assoc entity-symbol
2438 (iostruct-parameter-entities tokenbuf)))
2439 (if* (and (iostruct-do-entity tokenbuf)
2441 (assoc entity-symbol
2442 (iostruct-parameter-entities tokenbuf)))) then
2443 (setf p-value (rest p-value))
2444 (when (member entity-symbol (iostruct-entity-names tokenbuf))
2445 (xml-error (concatenate 'string
2447 (string entity-symbol)
2448 " in recursive reference")))
2449 (push entity-symbol (iostruct-entity-names tokenbuf))
2450 (if* (stringp p-value) then
2451 (setf p-value (concatenate 'string " " p-value " "))
2452 (add-to-entity-buf entity-symbol p-value)
2453 elseif (null external-callback) then
2454 (setf (iostruct-do-entity tokenbuf) nil)
2456 (let ((entity-stream (apply external-callback p-value)))
2458 (let ((entity-buf (get-tokenbuf)))
2459 (setf (tokenbuf-stream entity-buf) entity-stream)
2460 (unicode-check entity-stream tokenbuf)
2461 (add-to-entity-buf entity-symbol " ")
2463 (iostruct-entity-bufs tokenbuf))
2466 (if* (dotimes (i (length string) t)
2467 (setf cch (get-next-char tokenbuf))
2472 (schar string count)))
2477 (when (< count 0) (return))
2478 (un-next-char (schar string count))
2480 ;; swallow <?xml token
2481 (next-token tokenbuf external-callback nil)
2486 (when (< count 0) (return))
2487 (un-next-char (schar string count))
2489 (push #\space (iostruct-unget-char tokenbuf))
2493 (concatenate 'string
2494 (string entity-symbol)
2495 " parameter entity referenced but not declared"))
2497 (put-back-collector coll)
2499 elseif (xml-name-char-p ch) then (add-to-coll coll ch)
2502 (add-to-coll coll ch)
2503 (setq ch (get-next-char tokenbuf))
2506 (xml-error (concatenate 'string
2507 "Illegal DTD parameter entity name stating at: "
2508 (compute-coll-string coll))))))))