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.3 2003/07/11 18:02:41 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 #+allegro (:fbound parse-default-value)
151 #+lispworks (optimize (safety 0) (debug 3))
152 #-lispworks (optimize (speed 3) (safety 1)))
153 (macrolet ((add-to-entity-buf (entity-symbol p-value)
155 (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
156 (iostruct-entity-bufs tokenbuf))))
159 `(push ,ch (iostruct-unget-char tokenbuf)))
162 `(setf (collector-next ,coll) 0))
164 (add-to-coll (coll ch)
165 `(let ((.next. (collector-next ,coll)))
166 (if* (>= .next. (collector-max ,coll))
167 then (grow-and-add ,coll ,ch)
168 else (setf (schar (collector-data ,coll) .next.)
170 (setf (collector-next ,coll) (1+ .next.)))))
172 (to-preferred-case (ch)
173 ;; should check the case mode
174 `(char-downcase ,ch))
177 (let ((state state-dtdstart)
178 (coll (get-collector))
179 (entity (get-collector))
189 (reference-save-state)
196 (setq ch (get-next-char tokenbuf))
198 (format t "~@<dtd ~:Ichar: ~s ~:_state: ~s ~:_contents: ~s ~:_pending: ~s ~:_pending-type: ~s ~:_entity-names ~s~:>~%"
199 ch (or (cdr (assoc state dtd-parser-states)) state)
200 contents-to-return pending pending-type
201 (iostruct-entity-names tokenbuf)))
203 then (setf prev-state state)
205 (return) ;; eof -- exit loop
210 (if* (and (eq #\] ch)
211 external (> include-count 0)) then
212 (setf state state-dtd-!-include3)
213 elseif (and (eq #\] ch) (not external)) then (return)
214 elseif (eq #\< ch) then (setf state state-tokenstart)
215 elseif (xml-space-p ch) then nil
216 elseif (eq #\% ch) then (external-param-reference tokenbuf coll external-callback)
218 (add-to-coll coll ch)
219 (setq ch (get-next-char tokenbuf))
222 (xml-error (concatenate 'string
223 "illegal DTD characters, starting at: '"
224 (compute-coll-string coll)
227 (#.state-dtd-!-include3
228 (if* (eq #\] ch) then (setf state state-dtd-!-include4)
231 (add-to-coll coll ch)
232 (setq ch (get-next-char tokenbuf))
235 (xml-error (concatenate 'string
236 "illegal DTD token, starting at: ']"
237 (compute-coll-string coll)
239 (#.state-dtd-!-include4
240 (if* (eq #\> ch) then (return)
243 (add-to-coll coll ch)
244 (setq ch (get-next-char tokenbuf))
247 (xml-error (concatenate 'string
248 "illegal DTD token, starting at: ']]"
249 (compute-coll-string coll)
253 (if* (xml-name-start-char-p ch) then
254 (add-to-coll coll ch)
255 (setf state state-dtd-pref2)
257 (add-to-coll coll ch)
258 (setq ch (get-next-char tokenbuf))
261 (xml-error (concatenate 'string
262 "illegal DTD parameter reference name, starting at: '"
263 (compute-coll-string coll)
267 (if* (eq #\? ch) then (setf state state-dtd-?)
268 elseif (eq #\! ch) then (setf state state-dtd-!)
270 (add-to-coll coll ch)
271 (setq ch (get-next-char tokenbuf))
274 (xml-error (concatenate 'string
275 "illegal DTD characters, starting at: '<"
276 (compute-coll-string coll)
280 (if* (xml-name-char-p ch)
282 (add-to-coll coll ch)
283 elseif (and external (eq #\% ch)) then
284 (external-param-reference tokenbuf coll external-callback)
286 (when (not (xml-space-p ch))
287 (xml-error (concatenate 'string
288 "expecting name following: '<?"
289 (compute-coll-string coll)
290 "' ; got: '" (string ch) "'"))
292 (when (= (collector-next coll) 0)
293 (xml-error "null <? token"))
294 (if* (and (= (collector-next coll) 3)
295 (or (eq (elt (collector-data coll) 0) #\X)
296 (eq (elt (collector-data coll) 0) #\x))
297 (or (eq (elt (collector-data coll) 1) #\M)
298 (eq (elt (collector-data coll) 1) #\m))
299 (or (eq (elt (collector-data coll) 2) #\L)
300 (eq (elt (collector-data coll) 2) #\l)))
302 (xml-error "<?xml not allowed in dtd")
304 (setq tag-to-return (compute-tag coll))
305 (setf state state-dtd-?-2))
308 (if* (xml-space-p ch)
310 elseif (and external (eq #\% ch)) then
311 (external-param-reference tokenbuf coll external-callback)
312 elseif (not (xml-char-p ch))
313 then (xml-error "XML is not well formed") ;; no test
314 else (add-to-coll coll ch)
315 (setf state state-dtd-?-3)))
318 then (setf state state-dtd-?-4)
319 elseif (not (xml-char-p ch))
320 then (xml-error "XML is not well formed") ;; no test
321 else (add-to-coll coll ch)))
325 (push (compute-coll-string coll) contents-to-return)
328 else (setf state state-dtd-?-3)
329 (add-to-coll coll #\?)
330 (add-to-coll coll ch)))
332 (if* (eq #\- ch) then (setf state state-dtd-comment)
333 elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-token)
335 elseif (and (eq #\[ ch) external) then
336 (setf state state-dtd-!-cond)
338 (add-to-coll coll ch)
339 (setq ch (get-next-char tokenbuf))
342 (xml-error (concatenate 'string
343 "illegal DTD characters, starting at: '<!"
344 (compute-coll-string coll)
348 (if* (xml-space-p ch) then nil
349 elseif (and external (eq #\% ch)) then
350 (external-param-reference tokenbuf coll external-callback)
351 elseif (eq #\I ch) then (setf state state-dtd-!-cond2)
352 else (error "this should not happen")
355 (if* (eq #\N ch) then (setf state state-dtd-!-include)
357 elseif (eq #\G ch) then (setf state state-dtd-!-ignore)
359 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
361 (#.state-dtd-!-ignore
362 (if* (and (eq check-count 5) (eq ch #\E)) then
363 (setf state state-dtd-!-ignore2)
364 elseif (eq ch (elt "IGNORE" check-count)) then
366 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
368 (#.state-dtd-!-ignore2
369 (if* (xml-space-p ch) then nil
370 elseif (and external (eq #\% ch)) then
371 (external-param-reference tokenbuf coll external-callback)
372 elseif (eq #\[ ch) then (setf state state-dtd-!-ignore3)
374 else (xml-error "'[' missing after '<![Ignore'")))
375 (#.state-dtd-!-ignore3
376 (if* (eq #\< ch) then (setf state state-dtd-!-ignore4)
377 elseif (eq #\] ch) then (setf state state-dtd-!-ignore5)))
378 (#.state-dtd-!-ignore4
379 (if* (eq #\! ch) then (setf state state-dtd-!-ignore6)
380 else (un-next-char ch)
381 (setf state state-dtd-!-ignore3)))
382 (#.state-dtd-!-ignore5
383 (if* (eq #\] ch) then (setf state state-dtd-!-ignore7)
384 else (un-next-char ch)
385 (setf state state-dtd-!-ignore3)))
386 (#.state-dtd-!-ignore6
387 (if* (eq #\[ ch) then (incf ignore-count)
388 (setf state state-dtd-!-ignore3)
389 else (un-next-char ch)
390 (setf state state-dtd-!-ignore3)))
391 (#.state-dtd-!-ignore7
392 (if* (eq #\> ch) then (decf ignore-count)
393 (when (= ignore-count 0) (return))
394 else (un-next-char ch)
395 (setf state state-dtd-!-ignore3)))
396 (#.state-dtd-!-include
397 (if* (and (eq check-count 6) (eq ch #\E)) then
398 (setf state state-dtd-!-include2)
399 elseif (eq ch (elt "INCLUD" check-count)) then
401 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
403 (#.state-dtd-!-include2
404 (if* (xml-space-p ch) then nil
405 elseif (and external (eq #\% ch)) then
406 (external-param-reference tokenbuf coll external-callback)
407 elseif (eq #\[ ch) then (return)
408 else (xml-error "'[' missing after '<![INCLUDE'")))
411 then (setf state state-dtd-comment2)
412 (setf tag-to-return :comment)
413 else (clear-coll coll)
415 (add-to-coll coll ch)
416 (setq ch (get-next-char tokenbuf))
419 (xml-error (concatenate 'string
420 "illegal token following '<![-', starting at '<!-"
421 (compute-coll-string coll)
424 (#.state-dtd-comment2
426 then (setf state state-dtd-comment3)
427 else (add-to-coll coll ch)))
428 (#.state-dtd-comment3
430 then (setf state state-dtd-comment4)
431 else (setf state state-dtd-comment2)
432 (add-to-coll coll #\-) (add-to-coll coll ch)))
433 (#.state-dtd-comment4
435 then (push (compute-coll-string coll) contents-to-return)
438 else (clear-coll coll)
440 (add-to-coll coll ch)
441 (setq ch (get-next-char tokenbuf))
444 (xml-error (concatenate 'string
445 "illegal token following '--' comment terminator, starting at '--"
446 (compute-coll-string coll)
450 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
451 elseif (and external (eq #\% ch)) then
452 (external-param-reference tokenbuf coll external-callback)
453 elseif (xml-space-p ch) then
454 (setf tag-to-return (compute-tag coll))
456 (if* (eq tag-to-return :ELEMENT) then (setf state state-dtd-!-element)
457 elseif (eq tag-to-return :ATTLIST) then
458 (setf state state-dtd-!-attlist)
459 elseif (eq tag-to-return :ENTITY) then
461 (setf state state-dtd-!-entity)
462 elseif (eq tag-to-return :NOTATION) then
463 (setf state state-dtd-!-notation)
465 (xml-error (concatenate 'string
466 "illegal DTD characters, starting at: '<!"
467 (string tag-to-return)
470 (add-to-coll coll ch)
471 (setq ch (get-next-char tokenbuf))
474 (xml-error (concatenate 'string
475 "illegal DTD characters, starting at: '<!"
476 (compute-coll-string coll)
479 (#.state-dtd-!-notation
480 (if* (xml-space-p ch) then nil
481 elseif (and external (eq #\% ch)) then
482 (external-param-reference tokenbuf coll external-callback)
483 elseif (xml-name-start-char-p ch) then
484 (add-to-coll coll ch)
485 (setf state state-dtd-!-notation2)
487 (add-to-coll coll ch)
488 (setq ch (get-next-char tokenbuf))
491 (xml-error (concatenate 'string
492 "illegal DTD characters, starting at: '<!NOTATION "
493 (compute-coll-string coll)
496 (#.state-dtd-!-notation2
497 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
498 elseif (and external (eq #\% ch)) then
499 (external-param-reference tokenbuf coll external-callback)
500 elseif (xml-space-p ch) then
501 (push (compute-tag coll) contents-to-return)
503 (setf state state-dtd-!-notation3)
505 (add-to-coll coll ch)
506 (setq ch (get-next-char tokenbuf))
509 (xml-error (concatenate 'string
510 "illegal DTD <!NOTATION name: "
511 (compute-coll-string coll)
514 (#.state-dtd-!-notation3
515 (if* (xml-space-p ch) then nil
516 elseif (and external (eq #\% ch)) then
517 (external-param-reference tokenbuf coll external-callback)
518 elseif (xml-name-char-p ch) then
519 (add-to-coll coll ch)
520 (setf state state-dtd-!-entity6)
522 (add-to-coll coll ch)
523 (setq ch (get-next-char tokenbuf))
526 (xml-error (concatenate 'string
527 "illegal DTD <!NOTATION spec for "
528 (string (first contents-to-return))
530 (compute-coll-string coll)
533 (#.state-dtd-!-entity
534 (if* (eq #\% ch) then (push :param contents-to-return)
536 (setf state state-dtd-!-entity2)
537 elseif (xml-name-start-char-p ch) then
538 (add-to-coll coll ch)
540 (setf state state-dtd-!-entity3)
541 elseif (xml-space-p ch) then nil
542 elseif (and external (eq #\% ch)) then
543 (external-param-reference tokenbuf coll external-callback)
545 (add-to-coll coll ch)
546 (setq ch (get-next-char tokenbuf))
549 (xml-error (concatenate 'string
550 "illegal DTD characters, starting at: '<!ENTITY "
551 (compute-coll-string coll)
554 (#.state-dtd-!-entity2
555 (if* (xml-space-p ch) then (setf state state-dtd-!-entity7)
556 elseif (and external (eq #\% ch)) then
557 (external-param-reference tokenbuf coll external-callback)
559 (add-to-coll coll ch)
560 (setq ch (get-next-char tokenbuf))
563 (xml-error (concatenate 'string
564 "illegal DTD <!ENTITY spec for "
565 (string (first contents-to-return))
567 (compute-coll-string coll)
570 (#.state-dtd-!-entity3
571 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
572 elseif (and external (eq #\% ch)) then
573 (external-param-reference tokenbuf coll external-callback)
574 elseif (xml-space-p ch) then
575 (push (compute-tag coll) contents-to-return)
576 (setf contents-to-return
577 (nreverse contents-to-return))
579 (setf state state-dtd-!-entity4)
581 (add-to-coll coll ch)
582 (setq ch (get-next-char tokenbuf))
585 (xml-error (concatenate 'string
586 "illegal DTD <!ENTITY name: "
587 (compute-coll-string coll)
590 (#.state-dtd-!-entity4
591 (if* (xml-space-p ch) then nil
592 elseif (and external (eq #\% ch)) then
593 (external-param-reference tokenbuf coll external-callback)
594 elseif (or (eq #\' ch) (eq #\" ch)) then
595 (setf value-delim ch)
596 (setf state state-dtd-!-entity-value)
597 elseif (xml-name-start-char-p ch) then
598 (add-to-coll coll ch)
599 (setf state state-dtd-!-entity6)
601 (add-to-coll coll ch)
602 (setq ch (get-next-char tokenbuf))
605 (xml-error (concatenate 'string
606 "illegal DTD <!ENTITY spec: '"
607 (compute-coll-string coll)
610 (#.state-dtd-!-entity6
611 (if* (xml-name-char-p ch) ;; starting char already passed more restrictive test
613 (add-to-coll coll ch)
614 elseif (and external (eq #\% ch)) then
615 (external-param-reference tokenbuf coll external-callback)
617 (when (not (xml-space-p ch))
619 (add-to-coll coll ch)
620 (setq ch (get-next-char tokenbuf))
625 "illegal character in '"
626 (compute-coll-string coll)
627 "' in <! tag: " (string tag-to-return) " "
628 (string (first contents-to-return))
631 (let ((token (compute-tag coll)))
632 (push token contents-to-return)
634 (if* (eq :SYSTEM token) then (setf state state-!-dtd-system)
635 elseif (eq :PUBLIC token) then (setf state state-!-dtd-public)
638 "expected 'SYSTEM' or 'PUBLIC' got '"
639 (string (first contents-to-return))
640 "' in <! tag: " (string tag-to-return) " "
641 (string (second contents-to-return))))
644 (#.state-dtd-!-entity7
645 (if* (xml-space-p ch) then nil
646 elseif (and external (eq #\% ch)) then
647 (external-param-reference tokenbuf coll external-callback)
648 elseif (xml-name-start-char-p ch) then
649 (add-to-coll coll ch)
650 (setf state state-dtd-!-entity3)
652 (add-to-coll coll ch)
653 (setq ch (get-next-char tokenbuf))
656 (xml-error (concatenate 'string
657 "illegal DTD <!ENTITY % name: "
658 (compute-coll-string coll)
661 (#.state-!-dtd-public
662 (if* (xml-space-p ch) then nil
663 elseif (and external (eq #\% ch)) then
664 (external-param-reference tokenbuf coll external-callback)
665 elseif (or (eq #\" ch) (eq #\' ch)) then
666 (setf state state-!-dtd-public2)
667 (setf value-delim ch)
670 "expected quote or double-quote got: '"
672 "' in <! tag: " (string tag-to-return) " "
673 (string (second contents-to-return)) " "
674 (string (first contents-to-return))
676 (#.state-!-dtd-public2
677 (if* (eq value-delim ch) then
678 (push (setf public-string
679 (normalize-public-value
680 (compute-coll-string coll))) contents-to-return)
682 (setf state state-!-dtd-public3)
683 elseif (pub-id-char-p ch) then (add-to-coll coll ch)
685 (add-to-coll coll ch)
686 (setq ch (get-next-char tokenbuf))
691 "illegal character in string: '"
692 (compute-coll-string coll) "'"))
694 (#.state-!-dtd-public3
695 (if* (xml-space-p ch) then (setf state state-!-dtd-system)
696 elseif (and external (eq #\% ch)) then
697 (external-param-reference tokenbuf coll external-callback)
698 elseif (and (not entityp)
700 (setf state state-!-dtd-system)
704 (add-to-coll coll ch)
705 (setq ch (get-next-char tokenbuf))
710 "Expected space before: '"
711 (compute-coll-string coll) "'"))
713 (#.state-!-dtd-system
714 (if* (xml-space-p ch) then nil
715 elseif (and external (eq #\% ch)) then
716 (external-param-reference tokenbuf coll external-callback)
717 elseif (or (eq #\" ch) (eq #\' ch)) then
718 (setf state state-!-dtd-system2)
719 (setf value-delim ch)
720 elseif (and (not entityp)
721 (eq #\> ch)) then (return)
724 "expected quote or double-quote got: '"
726 "' in <! tag: " (string tag-to-return) " "
727 (string (second contents-to-return)) " "
728 (string (first contents-to-return))
730 (#.state-!-dtd-system2
731 (when (not (xml-char-p ch))
732 (xml-error "XML is not well formed")) ;; not tested
733 (if* (eq value-delim ch) then
734 (let ((entity-symbol (first (last contents-to-return)))
735 (system-string (compute-coll-string coll)))
737 (when (not (assoc entity-symbol (iostruct-parameter-entities tokenbuf)))
738 (setf (iostruct-parameter-entities tokenbuf)
739 (acons entity-symbol (list (parse-uri system-string)
742 (iostruct-parameter-entities tokenbuf)))
745 (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
746 (setf (iostruct-general-entities tokenbuf)
747 (acons entity-symbol (list (parse-uri system-string)
751 (iostruct-general-entities tokenbuf)))
752 (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
753 (setf (iostruct-general-entities tokenbuf)
754 (acons entity-symbol (list (parse-uri system-string)
758 (iostruct-general-entities tokenbuf))))
761 (push system-string contents-to-return))
763 (setf state state-!-dtd-system3)
764 else (add-to-coll coll ch)))
765 (#.state-!-dtd-system3
766 (if* (xml-space-p ch) then (setf state state-!-dtd-system4)
767 elseif (and external (eq #\% ch)) then
768 (external-param-reference tokenbuf coll external-callback)
769 elseif (eq #\> ch) then (return)
772 (add-to-coll coll ch)
773 (setq ch (get-next-char tokenbuf))
776 (xml-error (concatenate 'string
777 "illegal DTD <!ENTITY value for "
778 (string (first (nreverse contents-to-return)))
780 (compute-coll-string coll)
783 (#.state-!-dtd-system4
784 (if* (xml-space-p ch) then nil
785 elseif (and external (eq #\% ch)) then
786 (external-param-reference tokenbuf coll external-callback)
787 elseif (and (not pentityp) (xml-name-start-char-p ch)) then
788 (add-to-coll coll ch)
789 (setf state state-!-dtd-system5)
790 elseif (eq #\> ch) then (return)
792 (add-to-coll coll ch)
793 (setq ch (get-next-char tokenbuf))
796 (xml-error (concatenate 'string
797 "illegal DTD <!ENTITY value for "
798 (string (first (nreverse contents-to-return)))
800 (compute-coll-string coll)
803 (#.state-!-dtd-system5
804 (if* (xml-name-char-p ch) then
805 (add-to-coll coll ch)
806 elseif (and external (eq #\% ch)) then
807 (external-param-reference tokenbuf coll external-callback)
808 elseif (xml-space-p ch) then
809 (let ((token (compute-tag coll)))
810 (when (not (eq :NDATA token))
812 (add-to-coll coll ch)
813 (setq ch (get-next-char tokenbuf))
816 (xml-error (concatenate 'string
817 "illegal DTD <!ENTITY value for "
818 (string (first (nreverse contents-to-return)))
820 (compute-coll-string coll)
824 (push token contents-to-return)
825 (setf state state-!-dtd-system6))
827 (add-to-coll coll ch)
828 (setq ch (get-next-char tokenbuf))
831 (xml-error (concatenate 'string
832 "illegal DTD <!ENTITY value for "
833 (string (first (nreverse contents-to-return)))
835 (compute-coll-string coll)
838 (#.state-!-dtd-system6
839 (if* (xml-space-p ch) then nil
840 elseif (and external (eq #\% ch)) then
841 (external-param-reference tokenbuf coll external-callback)
842 elseif (xml-name-start-char-p ch) then
843 (add-to-coll coll ch)
844 (setf state state-!-dtd-system7)
846 (add-to-coll coll ch)
847 (setq ch (get-next-char tokenbuf))
850 (xml-error (concatenate 'string
851 "illegal DTD <!ENTITY value for "
852 (string (first (nreverse contents-to-return)))
854 (compute-coll-string coll)
857 (#.state-!-dtd-system7
858 (if* (xml-name-char-p ch) then
859 (add-to-coll coll ch)
860 elseif (and external (eq #\% ch)) then
861 (external-param-reference tokenbuf coll external-callback)
862 elseif (xml-space-p ch) then
863 (push (compute-tag coll) contents-to-return)
865 (setf state state-dtd-!-entity5) ;; just looking for space, >
866 elseif (eq #\> ch) then
867 (push (compute-tag coll) contents-to-return)
871 (add-to-coll coll ch)
872 (setq ch (get-next-char tokenbuf))
875 (xml-error (concatenate 'string
876 "illegal DTD <!ENTITY value for "
877 (string (first (nreverse contents-to-return)))
879 (compute-coll-string coll)
882 (#.state-dtd-!-entity-value
883 (if* (eq ch value-delim) then
884 (let ((tmp (compute-coll-string coll)))
885 (when (> (length tmp) 0)
886 (when (null (first pending)) (setf pending (rest pending)))
888 (if* (> (length pending) 1) then
889 (push (nreverse pending) contents-to-return)
890 else (push (first pending) contents-to-return))
891 (setf pending (list nil))
892 (setf state state-dtd-!-entity5)
895 (when (not (assoc (third contents-to-return)
896 (iostruct-parameter-entities tokenbuf)))
897 (setf (iostruct-parameter-entities tokenbuf)
898 (acons (third contents-to-return)
899 (first contents-to-return)
900 (iostruct-parameter-entities tokenbuf))))
902 (when (not (assoc (second contents-to-return)
903 (iostruct-general-entities tokenbuf)))
904 (setf (iostruct-general-entities tokenbuf)
905 (acons (second contents-to-return)
906 (first contents-to-return)
907 (iostruct-general-entities tokenbuf)))))
908 elseif (eq #\& ch) then
909 (setf reference-save-state state-dtd-!-entity-value)
910 (setf state state-dtd-!-attdef-decl-value3)
911 elseif (eq #\% ch) then
913 (setf reference-save-state state-dtd-!-entity-value)
914 (setf state state-dtd-!-attdef-decl-value3)
915 elseif (xml-char-p ch)
916 then (add-to-coll coll ch)
918 (add-to-coll coll ch)
919 (setq ch (get-next-char tokenbuf))
922 (xml-error (concatenate 'string
923 "illegal DTD <!ENTITY value for "
924 (string (first contents-to-return))
926 (compute-coll-string coll)
929 (#.state-dtd-!-entity5
930 (if* (xml-space-p ch) then nil
931 elseif (and external (eq #\% ch)) then
932 (external-param-reference tokenbuf coll external-callback)
933 elseif (eq #\> ch) then (return)
934 else (clear-coll coll)
936 (add-to-coll coll ch)
937 (setq ch (get-next-char tokenbuf))
940 (xml-error (concatenate 'string
941 "illegal DTD contents following <!ENTITY spec for "
942 (string (first contents-to-return))
944 (compute-coll-string coll)
947 (#.state-dtd-!-attlist
948 (if* (xml-name-start-char-p ch) then (setf state state-dtd-!-attlist-name)
950 elseif (xml-space-p ch) then nil
951 elseif (and external (eq #\% ch)) then
952 (external-param-reference tokenbuf coll external-callback)
954 (add-to-coll coll ch)
955 (setq ch (get-next-char tokenbuf))
958 (xml-error (concatenate 'string
959 "illegal DTD characters, starting at: '<!ATTLIST "
960 (compute-coll-string coll)
962 (#.state-dtd-!-attlist-name
963 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
964 elseif (and external (eq #\% ch)) then
965 (external-param-reference tokenbuf coll external-callback)
966 elseif (xml-space-p ch) then
967 (push (compute-tag coll *package*)
970 (setf state state-dtd-!-attdef)
971 elseif (eq #\> ch) then
972 (push (compute-tag coll *package*)
976 else (push (compute-tag coll)
980 (add-to-coll coll ch)
981 (setq ch (get-next-char tokenbuf))
984 (xml-error (concatenate 'string
985 "illegal DTD <!ATTLIST content spec for "
986 (string (first contents-to-return))
988 (compute-coll-string coll)
991 (#.state-dtd-!-attdef
992 (if* (xml-space-p ch) then nil
993 elseif (and external (eq #\% ch)) then
994 (external-param-reference tokenbuf coll external-callback)
995 elseif (xml-name-start-char-p ch) then
997 (setf state state-dtd-!-attdef-name)
998 elseif (eq #\> ch) then (return)
1000 (add-to-coll coll ch)
1001 (setq ch (get-next-char tokenbuf))
1004 (xml-error (concatenate 'string
1005 "illegal DTD <!ATTLIST content spec for "
1006 (string (first contents-to-return))
1008 (compute-coll-string coll)
1011 (#.state-dtd-!-attdef-name
1012 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1013 elseif (and external (eq #\% ch)) then
1014 (external-param-reference tokenbuf coll external-callback)
1015 elseif (xml-space-p ch) then
1016 (setf (first pending) (compute-tag coll *package*))
1018 (setf state state-dtd-!-attdef-type)
1019 else (dotimes (i 15)
1020 (add-to-coll coll ch)
1021 (setq ch (get-next-char tokenbuf))
1024 (xml-error (concatenate 'string
1025 "illegal DTD <!ATTLIST type spec for "
1026 (string (first contents-to-return))
1028 (compute-coll-string coll)
1031 (#.state-dtd-!-attdef-type
1032 (if* (xml-space-p ch) then nil
1033 elseif (and external (eq #\% ch)) then
1034 (external-param-reference tokenbuf coll external-callback)
1035 else (un-next-char ch)
1036 ;; let next state do all other checking
1037 (setf state state-dtd-!-attdef-type2)))
1038 (#.state-dtd-!-attdef-type2
1039 ;; can only be one of a few tokens, but wait until token built to check
1040 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1041 elseif (and (eq #\( ch) (= 0 (length (compute-coll-string coll)))) then
1042 (push (list :enumeration) pending)
1043 (setf state state-dtd-!-attdef-notation2)
1044 elseif (and external (eq #\% ch)) then
1045 (external-param-reference tokenbuf coll external-callback)
1046 elseif (xml-space-p ch) then
1047 (let ((token (compute-tag coll)))
1048 (when (and (not (eq :CDATA token))
1049 (not (eq :ID token))
1050 (not (eq :IDREF token))
1051 (not (eq :IDREFS token))
1052 (not (eq :ENTITY token))
1053 (not (eq :ENTITIES token))
1054 (not (eq :NMTOKEN token))
1055 (not (eq :NMTOKENS token))
1056 (not (eq :NOTATION token)))
1058 (add-to-coll coll ch)
1059 (setq ch (get-next-char tokenbuf))
1062 (xml-error (concatenate 'string
1063 "illegal DTD <!ATTLIST type spec for "
1064 (string (first contents-to-return))
1066 (compute-coll-string coll)
1068 (if* (eq token :NOTATION) then
1069 (push (list token) pending)
1070 (setf state state-dtd-!-attdef-notation)
1072 (push token pending)
1073 (setf state state-dtd-!-attdef-decl))
1076 else (dotimes (i 15)
1077 (add-to-coll coll ch)
1078 (setq ch (get-next-char tokenbuf))
1081 (xml-error (concatenate 'string
1082 "illegal DTD <!ATTLIST type spec for "
1083 (string (first contents-to-return))
1085 (compute-coll-string coll)
1088 (#.state-dtd-!-attdef-notation
1089 (if* (xml-space-p ch) then nil
1090 elseif (and external (eq #\% ch)) then
1091 (external-param-reference tokenbuf coll external-callback)
1092 elseif (eq #\( ch) then (setf state state-dtd-!-attdef-notation2)
1093 else (dotimes (i 15)
1094 (add-to-coll coll ch)
1095 (setq ch (get-next-char tokenbuf))
1098 (xml-error (concatenate 'string
1099 "illegal DTD <!ATTLIST type spec for "
1100 (string (first contents-to-return))
1102 (compute-coll-string coll)
1105 (#.state-dtd-!-attdef-notation2
1106 (if* (xml-space-p ch) then nil
1107 elseif (and external (eq #\% ch)) then
1108 (external-param-reference tokenbuf coll external-callback)
1109 elseif (xml-name-start-char-p ch) then
1110 (setf state state-dtd-!-attdef-notation3)
1111 (add-to-coll coll ch)
1112 elseif (and (xml-name-char-p ch) (listp (first pending))
1113 (eq :enumeration (first (reverse (first pending))))) then
1114 (setf state state-dtd-!-attdef-notation3)
1115 (add-to-coll coll ch)
1116 else (dotimes (i 15)
1117 (add-to-coll coll ch)
1118 (setq ch (get-next-char tokenbuf))
1121 (xml-error (concatenate 'string
1122 "illegal DTD <!ATTLIST type spec for "
1123 (string (first contents-to-return))
1125 (compute-coll-string coll)
1128 (#.state-dtd-!-attdef-notation3
1129 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1130 elseif (and external (eq #\% ch)) then
1131 (external-param-reference tokenbuf coll external-callback)
1132 elseif (and external (eq #\% ch)) then
1133 (external-param-reference tokenbuf coll external-callback)
1134 elseif (xml-space-p ch) then
1135 (push (compute-tag coll) (first pending))
1137 (setf state state-dtd-!-attdef-notation4)
1138 elseif (eq #\| ch) then
1139 (push (compute-tag coll) (first pending))
1141 (setf state state-dtd-!-attdef-notation2)
1142 elseif (eq #\) ch) then
1143 (push (compute-tag coll) (first pending))
1145 (setf (first pending) (nreverse (first pending)))
1146 ;;(setf state state-dtd-!-attdef-decl)
1147 (setf state state-dtd-!-attdef-notation5)
1148 else (dotimes (i 15)
1149 (add-to-coll coll ch)
1150 (setq ch (get-next-char tokenbuf))
1153 (xml-error (concatenate 'string
1154 "illegal DTD <!ATTLIST type spec for "
1155 (string (first contents-to-return))
1157 (compute-coll-string coll)
1160 (#.state-dtd-!-attdef-notation5
1161 (if* (xml-space-p ch) then (setf state state-dtd-!-attdef-decl)
1162 elseif (and external (eq #\% ch)) then
1163 (external-param-reference tokenbuf coll external-callback)
1166 (add-to-coll coll ch)
1167 (setq ch (get-next-char tokenbuf))
1171 (concatenate 'string
1172 "Expected space before: '"
1173 (compute-coll-string coll) "'"))))
1174 (#.state-dtd-!-attdef-notation4
1175 (if* (xml-space-p ch) then nil
1176 elseif (and external (eq #\% ch)) then
1177 (external-param-reference tokenbuf coll external-callback)
1178 elseif (xml-name-char-p ch) then (add-to-coll coll ch)
1179 (setf state state-dtd-!-attdef-notation3)
1180 elseif (eq #\| ch) then (setf state state-dtd-!-attdef-notation2)
1181 elseif (eq #\) ch) then (setf state state-dtd-!-attdef-decl)
1182 (setf (first pending) (nreverse (first pending)))
1183 else (dotimes (i 15)
1184 (add-to-coll coll ch)
1185 (setq ch (get-next-char tokenbuf))
1188 (xml-error (concatenate 'string
1189 "illegal DTD <!ATTLIST type spec for "
1190 (string (first contents-to-return))
1192 (compute-coll-string coll)
1195 (#.state-dtd-!-attdef-decl
1196 (if* (eq #\# ch) then
1197 (setf state state-dtd-!-attdef-decl-type)
1198 elseif (or (eq #\' ch) (eq #\" ch)) then
1199 (setf value-delim ch)
1200 (setf state state-dtd-!-attdef-decl-value)
1201 elseif (xml-space-p ch) then nil
1202 elseif (and external (eq #\% ch)) then
1203 (external-param-reference tokenbuf coll external-callback)
1204 else (dotimes (i 15)
1205 (add-to-coll coll ch)
1206 (setq ch (get-next-char tokenbuf))
1209 (xml-error (concatenate 'string
1210 "illegal DTD <!ATTLIST type spec for "
1211 (string (first contents-to-return))
1213 (compute-coll-string coll)
1216 (#.state-dtd-!-attdef-decl-value
1217 (if* (eq ch value-delim) then
1219 (push (first (parse-default-value (list (compute-coll-string coll))
1220 tokenbuf external-callback))
1223 (push (compute-coll-string coll) pending)
1224 (setf contents-to-return
1225 (append contents-to-return
1228 else (list (nreverse pending)))))
1229 (setf pending (list nil))
1230 (setf state state-dtd-!-attdef)
1232 elseif (eq #\& ch) then (setf state state-dtd-!-attdef-decl-value3)
1233 (setf reference-save-state state-dtd-!-attdef-decl-value)
1234 elseif (and (xml-char-p ch) (not (eq #\< ch)))
1235 then (add-to-coll coll ch)
1236 else (dotimes (i 15)
1237 (add-to-coll coll ch)
1238 (setq ch (get-next-char tokenbuf))
1241 (xml-error (concatenate 'string
1242 "illegal DTD <!ATTLIST type spec for "
1243 (string (first contents-to-return))
1245 (compute-coll-string coll)
1248 (#.state-dtd-!-attdef-decl-value3
1249 (if* (and (not prefp) (eq #\# ch))
1250 then (setf state state-dtd-!-attdef-decl-value4)
1251 elseif (xml-name-start-char-p ch)
1252 then (setf state state-dtd-!-attdef-decl-value5)
1253 (when (not prefp) (add-to-coll coll #\&))
1255 else (clear-coll coll)
1257 (add-to-coll coll ch)
1258 (setq ch (get-next-char tokenbuf))
1261 (xml-error (concatenate 'string
1262 "illegal reference name, starting at: '&"
1263 (compute-coll-string coll)
1265 (#.state-dtd-!-attdef-decl-value4
1267 then (setf state state-dtd-!-attdef-decl-value6)
1268 elseif (<= (char-code #\0) (char-code ch) (char-code #\9))
1269 then (setf state state-dtd-!-attdef-decl-value7)
1271 else (clear-coll coll)
1273 (add-to-coll coll ch)
1274 (setq ch (get-next-char tokenbuf))
1277 (xml-error (concatenate 'string
1278 "illegal character reference code, starting at: '&#"
1279 (compute-coll-string coll)
1282 (#.state-dtd-!-attdef-decl-value5
1283 (if* (xml-name-char-p ch)
1284 then (add-to-coll entity ch)
1285 (when (not prefp) (add-to-coll coll ch))
1288 (if* (not prefp) then (add-to-coll coll ch)
1289 elseif (not external) then
1291 (concatenate 'string
1292 "internal dtd subset cannot reference parameter entity within a token; entity: "
1293 (compute-coll-string entity)))
1295 (let* ((entity-symbol (compute-tag entity))
1297 (assoc entity-symbol (iostruct-parameter-entities tokenbuf))))
1299 (if* (and (iostruct-do-entity tokenbuf)
1301 (assoc entity-symbol
1302 (iostruct-parameter-entities tokenbuf)))) then
1303 (setf p-value (rest p-value))
1304 (when (member entity-symbol (iostruct-entity-names tokenbuf))
1305 (xml-error (concatenate 'string
1307 (string entity-symbol)
1308 " in recursive reference")))
1309 (push entity-symbol (iostruct-entity-names tokenbuf))
1310 (if* (stringp p-value) then
1311 (dotimes (i (length p-value))
1312 (add-to-coll coll (schar p-value i)))
1314 (if* (null external-callback) then
1315 (setf (iostruct-do-entity tokenbuf) nil)
1317 (let ((count 0) (string "<?xml ") last-ch
1321 (apply external-callback p-value)))
1323 (let ((tmp-buf (get-tokenbuf)))
1324 (setf (tokenbuf-stream tmp-buf)
1327 (iostruct-unget-char tokenbuf))
1328 (setf (iostruct-unget-char tokenbuf) nil)
1329 (unicode-check entity-stream tokenbuf)
1330 (when (iostruct-unget-char tokenbuf)
1331 (setf save-ch (first (iostruct-unget-char tokenbuf))))
1332 (setf (iostruct-unget-char tokenbuf) save-unget)
1343 (iostruct-read-sequence-func
1345 (when (null cch) (return))
1347 (format t "dtd-char: ~s~%" cch))
1348 (if* (< count 0) then
1349 (if* (and (eq last-ch #\?)
1352 else (setf last-ch cch))
1353 elseif (< count 6) then
1354 (when (and (= count 5)
1358 (schar string count)
1361 (when (= tmp-count count)
1367 (add-to-coll coll cch)
1370 elseif (= count 6) then
1372 (add-to-coll coll (schar string i)))
1374 else (add-to-coll coll cch))))
1375 (setf (iostruct-entity-names tokenbuf)
1376 (rest (iostruct-entity-names tokenbuf)))
1377 (close entity-stream)
1378 (put-back-tokenbuf tmp-buf)))))
1380 (setf state state-dtdstart)
1383 (setf state reference-save-state)
1384 else (let ((tmp (compute-coll-string entity)))
1387 (add-to-coll coll ch)
1388 (setq ch (get-next-char tokenbuf))
1391 (xml-error (concatenate 'string
1392 "reference not terminated by ';', starting at: '&"
1394 (compute-coll-string coll)
1397 (#.state-dtd-!-attdef-decl-value6
1398 (let ((code (char-code ch)))
1400 then (add-to-coll coll (code-char char-code))
1402 (setq state state-dtd-!-attdef-decl-value)
1403 elseif (<= (char-code #\0) code (char-code #\9))
1404 then (setf char-code (+ (* char-code 16) (- code (char-code #\0))))
1405 elseif (<= (char-code #\A) code (char-code #\F))
1406 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\A))))
1407 elseif (<= (char-code #\a) code (char-code #\f))
1408 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\a))))
1409 else (clear-coll coll)
1411 (add-to-coll coll ch)
1412 (setq ch (get-next-char tokenbuf))
1415 (xml-error (concatenate 'string
1416 "illegal hexidecimal character reference code, starting at: '"
1417 (compute-coll-string coll)
1418 "', calculated char code: "
1419 (format nil "~s" char-code)))
1421 (#.state-dtd-!-attdef-decl-value7
1422 (let ((code (char-code ch)))
1424 then (add-to-coll coll (code-char char-code))
1426 (setq state reference-save-state)
1427 elseif (<= (char-code #\0) code (char-code #\9))
1428 then (setf char-code (+ (* char-code 10) (- code (char-code #\0))))
1429 else (clear-coll coll)
1431 (add-to-coll coll ch)
1432 (setq ch (get-next-char tokenbuf))
1435 (xml-error (concatenate 'string
1436 "illegal decimal character reference code, starting at: '"
1437 (compute-coll-string coll)
1438 "', calculated char code: "
1439 (format nil "~s" char-code)))
1441 (#.state-dtd-!-attdef-decl-type
1442 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1443 elseif (and external (eq #\% ch)) then
1444 (external-param-reference tokenbuf coll external-callback)
1445 elseif (or (xml-space-p ch) (eq #\> ch)) then
1446 (let ((token (compute-tag coll)))
1447 (when (and (not (eq :REQUIRED token))
1448 (not (eq :IMPLIED token))
1449 (not (eq :FIXED token)))
1451 (add-to-coll coll ch)
1452 (setq ch (get-next-char tokenbuf))
1455 (xml-error (concatenate 'string
1456 "illegal DTD <!ATTLIST type spec for "
1457 (string (first contents-to-return))
1459 (compute-coll-string coll)
1461 (push token pending)
1462 (if* (eq :FIXED token) then
1465 (add-to-coll coll ch)
1466 (setq ch (get-next-char tokenbuf))
1469 (xml-error (concatenate 'string
1470 "illegal DTD <!ATTLIST type spec for "
1471 (string (first contents-to-return))
1473 (compute-coll-string coll)
1475 (setf state state-dtd-!-attdef-decl-value2)
1476 elseif (eq #\> ch) then
1477 (setf contents-to-return
1478 (append contents-to-return (list (nreverse pending))))
1480 else (setf contents-to-return
1481 (append contents-to-return (list (nreverse pending))))
1482 (setf pending (list nil))
1483 (setf state state-dtd-!-attdef)))
1485 else (dotimes (i 15)
1486 (add-to-coll coll ch)
1487 (setq ch (get-next-char tokenbuf))
1490 (xml-error (concatenate 'string
1491 "illegal DTD <!ATTLIST type spec for "
1492 (string (first contents-to-return))
1494 (compute-coll-string coll)
1497 (#. state-dtd-!-attdef-decl-value2
1498 (if* (xml-space-p ch) then nil
1499 elseif (and external (eq #\% ch)) then
1500 (external-param-reference tokenbuf coll external-callback)
1501 elseif (or (eq #\' ch) (eq #\" ch)) then
1502 (setf value-delim ch)
1503 (setf state state-dtd-!-attdef-decl-value)
1504 else (dotimes (i 15)
1505 (add-to-coll coll ch)
1506 (setq ch (get-next-char tokenbuf))
1509 (xml-error (concatenate 'string
1510 "illegal DTD <!ATTLIST type spec for "
1511 (string (first contents-to-return))
1513 (compute-coll-string coll)
1516 (#.state-dtd-!-element
1517 (if* (xml-space-p ch) then nil
1518 elseif (and external (eq #\% ch)) then
1519 (external-param-reference tokenbuf coll external-callback)
1520 elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-element-name)
1522 else (dotimes (i 15)
1523 (add-to-coll coll ch)
1524 (setq ch (get-next-char tokenbuf))
1527 (xml-error (concatenate 'string
1528 "illegal DTD characters, starting at: '<!ELEMENT "
1529 (compute-coll-string coll)
1531 (#.state-dtd-!-element-name
1532 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1533 elseif (and external (eq #\% ch)) then
1534 (external-param-reference tokenbuf coll external-callback)
1535 elseif (xml-space-p ch) then
1536 (push (compute-tag coll)
1539 (setf state state-dtd-!-element-type)
1540 else (dotimes (i 15)
1541 (add-to-coll coll ch)
1542 (setq ch (get-next-char tokenbuf))
1545 (xml-error (concatenate 'string
1546 "illegal DTD <!ELEMENT name: '"
1547 (compute-coll-string coll)
1550 (#.state-dtd-!-element-type
1551 (if* (eq #\( ch) then (setf state state-dtd-!-element-type-paren)
1552 elseif (xml-space-p ch) then nil
1553 elseif (and external (eq #\% ch)) then
1554 (external-param-reference tokenbuf coll external-callback)
1555 elseif (xml-name-start-char-p ch) then
1557 (setf state state-dtd-!-element-type-token)
1558 else (dotimes (i 15)
1559 (add-to-coll coll ch)
1560 (setq ch (get-next-char tokenbuf))
1563 (xml-error (concatenate 'string
1564 "illegal DTD <!ELEMENT content spec for "
1565 (string (first contents-to-return))
1567 (compute-coll-string coll)
1570 (#.state-dtd-!-element-type-paren
1571 (if* (xml-space-p ch) then nil
1572 elseif (and external (eq #\% ch)) then
1573 (external-param-reference tokenbuf coll external-callback)
1574 elseif (xml-name-start-char-p ch) then
1576 (setf state state-dtd-!-element-type-paren-name)
1577 elseif (eq #\# ch) then
1578 (setf state state-dtd-!-element-type-paren-pcd)
1579 elseif (eq #\( ch) then
1581 (setf state state-dtd-!-element-type-paren-choice-paren)
1582 else (dotimes (i 15)
1583 (add-to-coll coll ch)
1584 (setq ch (get-next-char tokenbuf))
1587 (xml-error (concatenate 'string
1588 "illegal DTD <!ELEMENT content spec for "
1589 (string (first contents-to-return))
1591 (compute-coll-string coll)
1593 (#.state-dtd-!-element-type-paren2
1594 (if* (eq #\> ch) then
1595 ;; there only one name...
1596 (setf (first contents-to-return) (first (first contents-to-return)))
1598 elseif (eq #\* ch) then
1599 (setf state state-dtd-!-element-type-paren-pcd5)
1600 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1601 (if* (> (length (first contents-to-return)) 1) then
1602 (setf (first contents-to-return)
1603 (list (append (list :choice)
1604 (first contents-to-return))))
1605 elseif (listp (first (first contents-to-return))) then
1606 (setf (first contents-to-return)
1607 (first (first contents-to-return))))
1608 (push :* (first contents-to-return))
1609 elseif (eq #\? ch) then
1610 (setf state state-dtd-!-element-type-paren-pcd5)
1611 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1612 (if* (> (length (first contents-to-return)) 1) then
1613 (setf (first contents-to-return)
1614 (list (append (list :choice)
1615 (first contents-to-return))))
1616 elseif (listp (first (first contents-to-return))) then
1617 (setf (first contents-to-return)
1618 (first (first contents-to-return))))
1619 (push :? (first contents-to-return))
1620 elseif (eq #\+ ch) then
1621 (setf state state-dtd-!-element-type-paren-pcd5)
1622 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1623 (if* (> (length (first contents-to-return)) 1) then
1624 (setf (first contents-to-return)
1625 (list (append (list :choice)
1626 (first contents-to-return))))
1627 elseif (listp (first (first contents-to-return))) then
1628 (setf (first contents-to-return)
1629 (first (first contents-to-return))))
1630 (push :+ (first contents-to-return))
1631 elseif (and external (eq #\% ch)) then
1632 (external-param-reference tokenbuf coll external-callback)
1633 elseif (xml-space-p ch) then
1634 (setf state state-dtd-!-element-type-paren-pcd5)
1635 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1636 (when (> (length (first contents-to-return)) 1)
1637 (setf (first contents-to-return)
1638 (list (append (list :\choice)
1639 (first contents-to-return)))))
1640 else (dotimes (i 15)
1641 (add-to-coll coll ch)
1642 (setq ch (get-next-char tokenbuf))
1645 (xml-error (concatenate 'string
1646 "illegal DTD <!ELEMENT content spec for "
1647 (string (first (reverse contents-to-return)))
1649 (compute-coll-string coll)
1652 (#.state-dtd-!-element-type-paren-name
1653 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1654 elseif (and external (eq #\% ch)) then
1655 (external-param-reference tokenbuf coll external-callback)
1656 elseif (xml-space-p ch) then
1657 (push (compute-tag coll) (first pending))
1659 (setf state state-dtd-!-element-type-paren-name2)
1660 elseif (eq #\? ch) then
1661 (push (compute-tag coll) (first pending))
1662 (setf (first pending)
1663 (list (push :? (first pending))))
1665 (setf state state-dtd-!-element-type-paren-name2)
1666 elseif (eq #\* ch) then
1667 (push (compute-tag coll) (first pending))
1668 (setf (first pending)
1669 (list (push :* (first pending))))
1671 (setf state state-dtd-!-element-type-paren-name2)
1672 elseif (eq #\+ ch) then
1673 (push (compute-tag coll) (first pending))
1674 (setf (first pending)
1675 (list (push :+ (first pending))))
1677 (setf state state-dtd-!-element-type-paren-name2)
1678 elseif (eq #\) ch) then
1679 (push (compute-tag coll) (first pending))
1681 (if* (= (length pending) 1) then
1682 (push (first pending) contents-to-return)
1683 (setf state state-dtd-!-element-type-paren2)
1684 else ;; this is (xxx)
1685 (if* (second pending) then
1686 (push (first pending) (second pending))
1687 else (setf (second pending) (first pending)))
1688 (setf pending (rest pending))
1689 (setf state state-dtd-!-element-type-paren-choice-name3)
1691 elseif (eq #\, ch) then
1692 (when (and (first pending) (not (eq :seq (first pending-type))))
1695 (add-to-coll coll ch)
1696 (setq ch (get-next-char tokenbuf))
1699 (xml-error (concatenate 'string
1700 "illegal '|' and ',' mix starting at '"
1701 (compute-coll-string coll)
1703 (push (compute-tag coll) (first pending))
1704 (push :seq pending-type)
1706 (setf state state-dtd-!-element-type-paren-choice)
1707 elseif (eq #\| ch) then
1708 (when (and (first pending) (not (eq :choice (first pending-type))))
1711 (add-to-coll coll ch)
1712 (setq ch (get-next-char tokenbuf))
1715 (xml-error (concatenate 'string
1716 "illegal '|' and ',' mix starting at '"
1717 (compute-coll-string coll)
1719 (push (compute-tag coll) (first pending))
1720 (push :choice pending-type)
1722 (setf state state-dtd-!-element-type-paren-choice)
1723 else (dotimes (i 15)
1724 (add-to-coll coll ch)
1725 (setq ch (get-next-char tokenbuf))
1728 (xml-error (concatenate 'string
1729 "illegal DTD <!ELEMENT content spec for "
1730 (string (first contents-to-return))
1732 (compute-coll-string coll)
1735 (#.state-dtd-!-element-type-paren-name2
1736 (if* (xml-space-p ch) then nil
1737 elseif (and external (eq #\% ch)) then
1738 (external-param-reference tokenbuf coll external-callback)
1739 elseif (eq #\| ch) then
1740 (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
1743 (add-to-coll coll ch)
1744 (setq ch (get-next-char tokenbuf))
1747 (xml-error (concatenate 'string
1748 "illegal '|' and ',' mix starting at '"
1749 (compute-coll-string coll)
1751 (push :choice pending-type)
1752 (setf state state-dtd-!-element-type-paren-choice)
1753 elseif (eq #\, ch) then
1754 (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
1757 (add-to-coll coll ch)
1758 (setq ch (get-next-char tokenbuf))
1761 (xml-error (concatenate 'string
1762 "illegal '|' and ',' mix starting at '"
1763 (compute-coll-string coll)
1765 (push :seq pending-type)
1766 (setf state state-dtd-!-element-type-paren-choice)
1767 elseif (eq #\) ch) then
1768 (if* (= (length pending) 1) then
1769 (push (list (first pending)) contents-to-return)
1770 (setf state state-dtd-!-element-type-paren2)
1771 else (setf pending (reverse (rest (reverse pending))))
1773 else (dotimes (i 15)
1774 (add-to-coll coll ch)
1775 (setq ch (get-next-char tokenbuf))
1778 (xml-error (concatenate 'string
1779 "illegal DTD <!ELEMENT content spec for "
1780 (string (first (reverse contents-to-return)))
1782 (compute-coll-string coll)
1786 (#.state-dtd-!-element-type-paren-choice
1787 (if* (xml-name-start-char-p ch) then
1789 (setf state state-dtd-!-element-type-paren-choice-name)
1790 elseif (xml-space-p ch) then nil
1791 elseif (and external (eq #\% ch)) then
1792 (external-param-reference tokenbuf coll external-callback)
1793 elseif (eq #\( ch) then
1795 (setf state state-dtd-!-element-type-paren-choice-paren)
1796 elseif (eq #\) ch) then
1797 (if* (= (length pending) 1) then
1798 (setf (first pending) (nreverse (first pending)))
1799 (if* (> (length (first pending)) 1) then
1800 (push (first pending-type) (first pending))
1801 (setf pending-type (rest pending-type))
1802 else (setf (first pending) (first (first pending))))
1803 (push (first pending) contents-to-return)
1804 (setf state state-dtd-!-element-type-paren3)
1805 else (setf (first pending) (nreverse (first pending)))
1806 (if* (> (length (first pending)) 1) then
1807 (push (first pending-type) (first pending))
1808 (setf pending-type (rest pending-type))
1809 else (setf (first pending) (first (first pending))))
1810 (if* (second pending) then
1811 (push (first pending) (second pending))
1812 else (setf (second pending) (list (first pending))))
1813 (setf pending (rest pending))
1814 (setf state state-dtd-!-element-type-paren-choice-name3)
1816 else (dotimes (i 15)
1817 (add-to-coll coll ch)
1818 (setq ch (get-next-char tokenbuf))
1821 (xml-error (concatenate 'string
1822 "illegal DTD <!ELEMENT content spec for "
1823 (string (first (reverse contents-to-return)))
1825 (compute-coll-string coll)
1829 (#.state-dtd-!-element-type-paren-choice-paren
1830 (if* (xml-name-start-char-p ch) then
1831 (setf state state-dtd-!-element-type-paren-name)
1833 elseif (eq #\( ch) then (push nil pending)
1834 elseif (xml-space-p ch) then nil
1835 elseif (and external (eq #\% ch)) then
1836 (external-param-reference tokenbuf coll external-callback)
1837 else (dotimes (i 15)
1838 (add-to-coll coll ch)
1839 (setq ch (get-next-char tokenbuf))
1842 (xml-error (concatenate 'string
1843 "illegal DTD <!ELEMENT content spec for "
1844 (string (first contents-to-return))
1846 (compute-coll-string coll)
1849 (#.state-dtd-!-element-type-paren-choice-name
1850 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1851 elseif (and external (eq #\% ch)) then
1852 (external-param-reference tokenbuf coll external-callback)
1853 elseif (xml-space-p ch) then
1854 (push (compute-tag coll) (first pending))
1856 (setf state state-dtd-!-element-type-paren-choice-name2)
1857 elseif (eq #\? ch) then
1858 (push (list :? (compute-tag coll)) (first pending))
1860 (setf state state-dtd-!-element-type-paren-choice-name2)
1861 elseif (eq #\* ch) then
1862 (push (list :* (compute-tag coll)) (first pending))
1864 (setf state state-dtd-!-element-type-paren-choice-name2)
1865 elseif (eq #\+ ch) then
1866 (push (list :+ (compute-tag coll)) (first pending))
1868 (setf state state-dtd-!-element-type-paren-choice-name2)
1869 elseif (eq #\) ch) then
1870 (push (compute-tag coll) (first pending))
1872 (if* (= (length pending) 1) then
1873 (setf (first pending) (nreverse (first pending)))
1874 (if* (> (length (first pending)) 1) then
1875 (push (first pending-type) (first pending))
1876 (setf pending-type (rest pending-type))
1877 else (setf (first pending) (first (first pending))))
1878 (push (first pending) contents-to-return)
1879 (setf state state-dtd-!-element-type-paren3)
1880 else (setf (first pending) (nreverse (first pending)))
1881 (push (first pending-type) (first pending))
1882 (setf pending-type (rest pending-type))
1883 (if* (second pending) then
1884 (push (first pending) (second pending))
1885 else (setf (second pending)
1886 ;; (list (first pending)) ;2001-03-22
1887 (first pending) ;2001-03-22
1889 (setf pending (rest pending))
1890 (setf state state-dtd-!-element-type-paren-choice-name3)
1892 elseif (eq #\, ch) then
1893 (when (and (first pending) (not (eq :seq (first pending-type))))
1896 (add-to-coll coll ch)
1897 (setq ch (get-next-char tokenbuf))
1900 (xml-error (concatenate 'string
1901 "illegal '|' and ',' mix starting at '"
1902 (compute-coll-string coll)
1904 (push (compute-tag coll) (first pending))
1906 (push :seq pending-type)
1907 (setf state state-dtd-!-element-type-paren-choice)
1908 elseif (eq #\| ch) then
1909 (when (and (first pending) (not (eq :choice (first pending-type))))
1912 (add-to-coll coll ch)
1913 (setq ch (get-next-char tokenbuf))
1916 (xml-error (concatenate 'string
1917 "illegal '|' and ',' mix starting at '"
1918 (compute-coll-string coll)
1920 (push (compute-tag coll) (first pending))
1922 (push :choice pending-type)
1923 (setf state state-dtd-!-element-type-paren-choice)
1924 else (dotimes (i 15)
1925 (add-to-coll coll ch)
1926 (setq ch (get-next-char tokenbuf))
1929 (xml-error (concatenate 'string
1930 "illegal DTD <!ELEMENT content spec for "
1931 (string (first contents-to-return))
1933 (compute-coll-string coll)
1936 (#.state-dtd-!-element-type-paren-choice-name2
1938 ;; begin changes 2001-03-22
1939 then (setf state state-dtd-!-element-type-paren-choice)
1940 (push :choice pending-type)
1942 then (setf state state-dtd-!-element-type-paren-choice)
1943 (push :seq pending-type)
1944 ;; end changes 2001-03-22
1945 elseif (xml-space-p ch) then nil
1946 elseif (and external (eq #\% ch)) then
1947 (external-param-reference tokenbuf coll external-callback)
1948 elseif (eq #\) ch) then
1949 (if* (= (length pending) 1) then
1950 (setf (first pending) (nreverse (first pending)))
1951 (if* (> (length (first pending)) 1) then
1952 (push (first pending-type) (first pending))
1953 (setf pending-type (rest pending-type))
1954 else (setf (first pending) (first (first pending))))
1955 (push (first pending) contents-to-return)
1956 (setf state state-dtd-!-element-type-paren3)
1957 else (setf (first pending) (nreverse (first pending)))
1958 (push (first pending-type) (first pending))
1959 (setf pending-type (rest pending-type))
1960 (if* (second pending) then
1961 (push (first pending) (second pending))
1962 else (setf (second pending) (list (first pending))))
1963 (setf state state-dtd-!-element-type-paren-choice-name3)
1965 (setf pending (rest pending))
1966 else (dotimes (i 15)
1967 (add-to-coll coll ch)
1968 (setq ch (get-next-char tokenbuf))
1971 (xml-error (concatenate 'string
1972 "illegal DTD <!ELEMENT content spec for "
1973 (string (first contents-to-return))
1975 (compute-coll-string coll)
1978 (#.state-dtd-!-element-type-paren-choice-name3
1979 (if* (xml-space-p ch) then nil
1980 elseif (and external (eq #\% ch)) then
1981 (external-param-reference tokenbuf coll external-callback)
1982 elseif (eq #\? ch) then
1983 (setf (first pending) (list :? (first pending)))
1984 (setf state state-dtd-!-element-type-paren-choice-name2)
1985 elseif (eq #\* ch) then
1986 (setf (first pending) (list :* (first pending)))
1987 (setf state state-dtd-!-element-type-paren-choice-name2)
1988 elseif (eq #\+ ch) then
1989 (setf (first pending) (list :+ (first pending)))
1990 (setf state state-dtd-!-element-type-paren-choice-name2)
1991 elseif (eq #\) ch) then
1992 (if* (= (length pending) 1) then
1993 (setf (first pending) (nreverse (first pending)))
1994 (if* (> (length (first pending)) 1) then
1995 (push (first pending-type) (first pending))
1996 (setf pending-type (rest pending-type))
1997 else (setf (first pending) (first (first pending))))
1998 (push (first pending) contents-to-return)
1999 (setf pending (rest pending))
2000 (setf state state-dtd-!-element-type-paren3)
2001 else (setf (first pending) (nreverse (first pending)))
2002 (if* (> (length (first pending)) 1) then
2003 (push (first pending-type) (first pending))
2004 (setf pending-type (rest pending-type))
2005 else (setf (first pending) (first (first pending))))
2006 (if* (second pending) then
2007 (push (first pending) (second pending))
2008 else (setf (second pending) (list (first pending))))
2009 (setf pending (rest pending))
2010 (setf state state-dtd-!-element-type-paren-choice)
2012 elseif (eq #\, ch) then
2013 (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
2016 (add-to-coll coll ch)
2017 (setq ch (get-next-char tokenbuf))
2020 (xml-error (concatenate 'string
2021 "illegal '|' and ',' mix starting at '"
2022 (compute-coll-string coll)
2024 (push :seq pending-type)
2025 (setf state state-dtd-!-element-type-paren-choice)
2026 elseif (eq #\| ch) then
2027 (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
2030 (add-to-coll coll ch)
2031 (setq ch (get-next-char tokenbuf))
2034 (xml-error (concatenate 'string
2035 "illegal '|' and ',' mix starting at '"
2036 (compute-coll-string coll)
2038 (push :choice pending-type)
2039 (setf state state-dtd-!-element-type-paren-choice)
2040 else (dotimes (i 15)
2041 (add-to-coll coll ch)
2042 (setq ch (get-next-char tokenbuf))
2045 (xml-error (concatenate 'string
2046 "illegal DTD <!ELEMENT content spec for "
2047 (string (first contents-to-return))
2049 (compute-coll-string coll)
2052 (#.state-dtd-!-element-type-paren3
2053 (if* (eq #\+ ch) then
2054 (setf (first contents-to-return)
2055 (append (list :+) (list (first contents-to-return))))
2056 (setf state state-dtd-!-element-type-paren-pcd5)
2057 elseif (eq #\? ch) then
2058 (setf (first contents-to-return)
2059 (append (list :?) (list (first contents-to-return))))
2060 (setf state state-dtd-!-element-type-paren-pcd5)
2061 elseif (eq #\* ch) then
2062 (setf (first contents-to-return)
2063 (append (list :*) (list (first contents-to-return))))
2064 (setf state state-dtd-!-element-type-paren-pcd5)
2065 elseif (and external (eq #\% ch)) then
2066 (external-param-reference tokenbuf coll external-callback)
2067 elseif (xml-space-p ch) then
2068 (setf state state-dtd-!-element-type-paren-pcd5)
2069 elseif (eq #\> ch) then (return)
2070 else (dotimes (i 15)
2071 (add-to-coll coll ch)
2072 (setq ch (get-next-char tokenbuf))
2075 (xml-error (concatenate 'string
2076 "illegal DTD <!ELEMENT content spec for "
2077 (string (first (reverse contents-to-return)))
2079 (compute-coll-string coll)
2082 (#.state-dtd-!-element-type-paren-pcd
2083 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2084 elseif (and external (eq #\% ch)) then
2085 (external-param-reference tokenbuf coll external-callback)
2086 elseif (xml-space-p ch) then
2087 (let ((token (compute-tag coll)))
2088 (when (not (eq token :PCDATA))
2089 (xml-error (concatenate 'string
2090 "illegal DTD <!ELEMENT content spec for "
2091 (string (first contents-to-return))
2093 (compute-coll-string coll)
2096 (push token contents-to-return))
2097 (setf state state-dtd-!-element-type-paren-pcd2)
2098 elseif (eq #\| ch) then
2099 (let ((token (compute-tag coll)))
2100 (when (not (eq token :PCDATA))
2101 (xml-error (concatenate 'string
2102 "illegal DTD <!ELEMENT content spec for "
2103 (string (first contents-to-return))
2105 (compute-coll-string coll)
2107 (push token contents-to-return))
2109 (setf state state-dtd-!-element-type-paren-pcd3)
2110 elseif (eq #\) ch) then
2111 (let ((token (compute-tag coll)))
2112 (when (not (eq token :PCDATA))
2113 (xml-error (concatenate 'string
2114 "illegal DTD <!ELEMENT content spec for "
2115 (string (first contents-to-return))
2117 (compute-coll-string coll)
2119 (push token contents-to-return))
2120 (setf state state-dtd-!-element-type-paren-pcd4)
2121 else (dotimes (i 15)
2122 (add-to-coll coll ch)
2123 (setq ch (get-next-char tokenbuf))
2126 (xml-error (concatenate 'string
2127 "illegal DTD <!ELEMENT content spec for "
2128 (string (first contents-to-return))
2130 (compute-coll-string coll)
2133 (#.state-dtd-!-element-type-paren-pcd2
2134 (if* (xml-space-p ch) then nil
2135 elseif (and external (eq #\% ch)) then
2136 (external-param-reference tokenbuf coll external-callback)
2137 elseif (eq #\) ch) then
2138 (setf state state-dtd-!-element-type-paren-pcd4)
2139 elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2140 else (dotimes (i 15)
2141 (add-to-coll coll ch)
2142 (setq ch (get-next-char tokenbuf))
2145 (xml-error (concatenate 'string
2146 "illegal DTD <!ELEMENT content spec for "
2147 (string (first (reverse contents-to-return)))
2149 (compute-coll-string coll)
2152 (#.state-dtd-!-element-type-paren-pcd3
2153 (if* (xml-space-p ch) then nil
2154 elseif (and external (eq #\% ch)) then
2155 (external-param-reference tokenbuf coll external-callback)
2156 elseif (xml-name-start-char-p ch) then
2158 (setf state state-dtd-!-element-type-paren-pcd7)
2159 else (dotimes (i 15)
2160 (add-to-coll coll ch)
2161 (setq ch (get-next-char tokenbuf))
2164 (xml-error (concatenate 'string
2165 "illegal DTD <!ELEMENT content spec for "
2166 (string (first (reverse contents-to-return)))
2168 (compute-coll-string coll)
2171 (#.state-dtd-!-element-type-paren-pcd4
2172 (if* (xml-space-p ch) then
2173 (setf state state-dtd-!-element-type-paren-pcd6)
2174 elseif (and external (eq #\% ch)) then
2175 (external-param-reference tokenbuf coll external-callback)
2176 elseif (eq #\* ch) then
2177 (setf (first contents-to-return) '(:* :PCDATA))
2178 (setf state state-dtd-!-element-type-paren-pcd5)
2179 elseif (eq #\> ch) then (return)
2180 else (clear-coll coll)
2182 (add-to-coll coll ch)
2183 (setq ch (get-next-char tokenbuf))
2186 (xml-error (concatenate 'string
2187 "illegal DTD contents following <!ELEMENT content spec for "
2188 (string (first (reverse contents-to-return)))
2190 (compute-coll-string coll)
2193 (#.state-dtd-!-element-type-paren-pcd5
2194 (if* (xml-space-p ch) then nil
2195 elseif (and external (eq #\% ch)) then
2196 (external-param-reference tokenbuf coll external-callback)
2197 elseif (eq #\> ch) then (return)
2198 else (clear-coll coll)
2200 (add-to-coll coll ch)
2201 (setq ch (get-next-char tokenbuf))
2204 (xml-error (concatenate 'string
2205 "illegal DTD contents following <!ELEMENT content spec for "
2206 (string (first (reverse contents-to-return)))
2208 (compute-coll-string coll)
2211 (#.state-dtd-!-element-type-paren-pcd6
2212 (if* (xml-space-p ch) then nil
2213 elseif (and external (eq #\% ch)) then
2214 (external-param-reference tokenbuf coll external-callback)
2215 elseif (eq #\> ch) then (return)
2216 else (clear-coll coll)
2218 (add-to-coll coll ch)
2219 (setq ch (get-next-char tokenbuf))
2222 (xml-error (concatenate 'string
2223 "illegal DTD contents following <!ELEMENT content spec for "
2224 (string (first (reverse contents-to-return)))
2226 (compute-coll-string coll)
2229 (#.state-dtd-!-element-type-paren-pcd7
2230 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2231 elseif (and external (eq #\% ch)) then
2232 (external-param-reference tokenbuf coll external-callback)
2233 elseif (xml-space-p ch) then
2234 (setf state state-dtd-!-element-type-paren-pcd8)
2235 (let ((token (compute-tag coll)))
2237 (if* (listp (first contents-to-return)) then
2238 (push token (first contents-to-return))
2239 else (setf (first contents-to-return)
2240 (list token (first contents-to-return)))))
2241 elseif (eq #\) ch) then
2242 (setf state state-dtd-!-element-type-paren-pcd9)
2243 (let ((token (compute-tag coll)))
2245 (if* (listp (first contents-to-return)) then
2246 (push token (first contents-to-return))
2247 else (setf (first contents-to-return)
2248 (list token (first contents-to-return)))))
2249 else (clear-coll coll)
2251 (add-to-coll coll ch)
2252 (setq ch (get-next-char tokenbuf))
2255 (xml-error (concatenate 'string
2256 "illegal DTD contents in <!ELEMENT content spec for "
2257 (string (first (reverse contents-to-return)))
2259 (compute-coll-string coll)
2262 (#.state-dtd-!-element-type-paren-pcd8
2263 (if* (xml-space-p ch) then nil
2264 elseif (and external (eq #\% ch)) then
2265 (external-param-reference tokenbuf coll external-callback)
2266 elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2267 elseif (eq #\) ch) then (setf state state-dtd-!-element-type-paren-pcd9)
2268 else (clear-coll coll)
2270 (add-to-coll coll ch)
2271 (setq ch (get-next-char tokenbuf))
2274 (xml-error (concatenate 'string
2275 "illegal DTD contents in <!ELEMENT content spec for "
2276 (string (first (reverse contents-to-return)))
2278 (compute-coll-string coll)
2281 (#.state-dtd-!-element-type-paren-pcd9
2282 (if* (eq #\* ch) then (setf state state-dtd-!-element-type-paren-pcd5)
2283 (setf (first contents-to-return) (nreverse (first contents-to-return)))
2284 (when (> (length (first contents-to-return)) 1)
2285 (setf (first contents-to-return)
2286 (list (append (list :choice)
2287 (first contents-to-return)))))
2288 (push :* (first contents-to-return))
2289 else (clear-coll coll)
2291 (add-to-coll coll ch)
2292 (setq ch (get-next-char tokenbuf))
2295 (xml-error (concatenate 'string
2296 "illegal DTD contents in <!ELEMENT content spec for "
2297 (string (first (reverse contents-to-return)))
2299 (compute-coll-string coll)
2302 (#.state-dtd-!-element-type-token
2303 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2304 elseif (and external (eq #\% ch)) then
2305 (external-param-reference tokenbuf coll external-callback)
2306 elseif (xml-space-p ch) then
2307 (let ((token (compute-tag coll)))
2308 (when (not (or (eq token :EMPTY) (eq token :ANY)))
2309 (xml-error (concatenate 'string
2310 "illegal DTD <!ELEMENT content spec for "
2311 (string (first contents-to-return))
2313 (compute-coll-string coll)
2315 (push token contents-to-return)
2316 (setf state state-dtd-!-element-type-end))
2317 elseif (eq #\> ch) then
2318 (let ((token (compute-tag coll)))
2319 (when (not (or (eq token :EMPTY) (eq token :ANY)))
2320 (xml-error (concatenate 'string
2321 "illegal DTD <!ELEMENT content spec for "
2322 (string (first contents-to-return))
2324 (compute-coll-string coll)
2326 (push token contents-to-return)
2328 else (add-to-coll coll ch)
2329 (xml-error (concatenate 'string
2330 "illegal DTD <!ELEMENT content spec for "
2331 (string (first contents-to-return))
2333 (compute-coll-string coll)
2337 (#.state-dtd-!-element-type-end
2338 (if* (xml-space-p ch) then nil
2339 elseif (and external (eq #\% ch)) then
2340 (external-param-reference tokenbuf coll external-callback)
2341 elseif (eq #\> ch) then (return)
2342 else (xml-error (concatenate 'string
2343 "expected '>', got '"
2345 "' in DTD <! ELEMENT "
2346 (string (first contents-to-return))
2348 (string (second contents-to-return))))
2351 (error "need to support dtd state:~s" state))))
2352 (put-back-collector entity)
2353 (put-back-collector coll)
2356 (when (and (null ch) (not external))
2357 (xml-error "unexpected end of input while parsing DTD"))
2358 (if* (null tag-to-return) then (values nil :end-dtd)
2359 else (error "process other return state")))
2360 ((#.state-dtd-!-element-type-end #.state-dtd-!-element-type-token
2361 #.state-dtd-!-element-type-paren-pcd4 #.state-dtd-!-element-type-paren-pcd6
2362 #.state-dtd-!-element-type-paren-pcd5 #.state-dtd-!-element-type-paren2
2363 #.state-dtd-!-element-type-paren3)
2364 (values (append (list tag-to-return) (nreverse contents-to-return))
2366 ((#.state-dtd-!-attdef-decl-type #.state-dtd-!-attlist-name
2367 #.state-dtd-!-attdef)
2368 (values (append (list tag-to-return) contents-to-return)
2370 ((#.state-dtd-!-entity5 #.state-!-dtd-system3
2371 #.state-!-dtd-system7 #.state-!-dtd-system4
2372 #.state-!-dtd-system ;; this is actually a !NOTATION
2373 #.state-dtd-?-4 ;; PI
2374 #.state-dtd-comment4 ;; comment
2376 (let ((ret (append (list tag-to-return) (nreverse contents-to-return))))
2381 (values (nreverse contents-to-return) nil))
2382 (#.state-dtd-!-include2
2383 (values nil :include))
2384 (#.state-dtd-!-include4
2385 (values nil :include-end))
2386 (#.state-dtd-!-ignore7
2387 (values nil :ignore))
2389 (if* (not external) then
2390 (xml-error "unexpected end of input while processing DTD internal subset")
2391 elseif (or (> include-count 0) (not (eq prev-state state-dtdstart))) then
2392 (xml-error "unexpected end of input while processing external DTD"))
2393 (values nil :end-dtd))
2395 (print (list tag-to-return contents-to-return))
2396 (error "need to support dtd <post> state:~s" state)))
2400 (defun external-param-reference (tokenbuf old-coll external-callback)
2401 (declare #+allegro (:fbound next-token)
2402 #+lispworks (optimize (safety 0) (debug 3))
2403 (ignorable old-coll)
2404 #-lispworks (optimize (speed 3) (safety 1)))
2405 (setf (iostruct-seen-parameter-reference tokenbuf) t)
2406 (macrolet ((add-to-entity-buf (entity-symbol p-value)
2408 (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
2409 (iostruct-entity-bufs tokenbuf))))
2411 `(setf (collector-next ,coll) 0))
2413 `(push ,ch (iostruct-unget-char tokenbuf)))
2414 (add-to-coll (coll ch)
2415 `(let ((.next. (collector-next ,coll)))
2416 (if* (>= .next. (collector-max ,coll))
2417 then (grow-and-add ,coll ,ch)
2418 else (setf (schar (collector-data ,coll) .next.)
2420 (setf (collector-next ,coll) (1+ .next.))))))
2421 (let ((ch (get-next-char tokenbuf))
2422 (coll (get-collector))
2423 p-value entity-symbol)
2424 (add-to-coll coll ch)
2425 (when (not (xml-name-start-char-p ch))
2427 (add-to-coll coll ch)
2428 (setq ch (get-next-char tokenbuf))
2431 (xml-error (concatenate 'string
2432 "Illegal DTD parameter entity name starting at: "
2433 (compute-coll-string coll))))
2435 (setf ch (get-next-char tokenbuf))
2436 (if* (eq #\; ch) then
2437 (setf entity-symbol (compute-tag coll))
2439 #+ignore (format t "entity symbol: ~s entities: ~s match: ~s~%"
2440 entity-symbol (iostruct-parameter-entities tokenbuf)
2441 (assoc entity-symbol
2442 (iostruct-parameter-entities tokenbuf)))
2443 (if* (and (iostruct-do-entity tokenbuf)
2445 (assoc entity-symbol
2446 (iostruct-parameter-entities tokenbuf)))) then
2447 (setf p-value (rest p-value))
2448 (when (member entity-symbol (iostruct-entity-names tokenbuf))
2449 (xml-error (concatenate 'string
2451 (string entity-symbol)
2452 " in recursive reference")))
2453 (push entity-symbol (iostruct-entity-names tokenbuf))
2454 (if* (stringp p-value) then
2455 (setf p-value (concatenate 'string " " p-value " "))
2456 (add-to-entity-buf entity-symbol p-value)
2457 elseif (null external-callback) then
2458 (setf (iostruct-do-entity tokenbuf) nil)
2460 (let ((entity-stream (apply external-callback p-value)))
2462 (let ((entity-buf (get-tokenbuf)))
2463 (setf (tokenbuf-stream entity-buf) entity-stream)
2464 (unicode-check entity-stream tokenbuf)
2465 (add-to-entity-buf entity-symbol " ")
2467 (iostruct-entity-bufs tokenbuf))
2470 (if* (dotimes (i (length string) t)
2471 (setf cch (get-next-char tokenbuf))
2476 (schar string count)))
2481 (when (< count 0) (return))
2482 (un-next-char (schar string count))
2484 ;; swallow <?xml token
2485 (next-token tokenbuf external-callback nil)
2490 (when (< count 0) (return))
2491 (un-next-char (schar string count))
2493 (push #\space (iostruct-unget-char tokenbuf))
2497 (concatenate 'string
2498 (string entity-symbol)
2499 " parameter entity referenced but not declared"))
2501 (put-back-collector coll)
2503 elseif (xml-name-char-p ch) then (add-to-coll coll ch)
2506 (add-to-coll coll ch)
2507 (setq ch (get-next-char tokenbuf))
2510 (xml-error (concatenate 'string
2511 "Illegal DTD parameter entity name stating at: "
2512 (compute-coll-string coll))))))))