pxml3.cl

   1 ;;
   2 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
   3 ;;
   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.
   9 ;;
  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.
  14 ;;
  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
  21 ;;
  22 ;; $Id: pxml3.cl,v 1.1 2002/10/15 12:23:03 kevin Exp $
  23
  24 (in-package :net.xml.parser)
  25
  26 (pxml-dribble-bug-hook "$Id: pxml3.cl,v 1.1 2002/10/15 12:23:03 kevin Exp $")
  27
  28 (defvar *debug-dtd* nil)
  29
  30 (defun parse-dtd (tokenbuf
  31                   external external-callback)
  32   (declare (optimize (speed 3) (safety 1)))
  33   (let ((guts)
  34         (include-count 0))
  35     (loop
  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
  42                 (incf include-count)
  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)))))))
  48
  49 (defparameter dtd-parser-states ())
  50
  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)
 147   )
 148
 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)
 153                `(progn
 154                   (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
 155                         (iostruct-entity-bufs tokenbuf))))
 156
 157              (un-next-char (ch)
 158                `(push ,ch (iostruct-unget-char tokenbuf)))
 159
 160              (clear-coll (coll)
 161                `(setf (collector-next ,coll) 0))
 162
 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.)
 168                             ,ch)
 169                           (setf (collector-next ,coll) (1+ .next.)))))
 170
 171              (to-preferred-case (ch)
 172                ;; should check the case mode
 173                `(char-downcase ,ch))
 174
 175              )
 176     (let ((state state-dtdstart)
 177           (coll  (get-collector))
 178           (entity  (get-collector))
 179           (tag-to-return)
 180           (contents-to-return)
 181           (pending (list nil))
 182           (pending-type)
 183           (value-delim)
 184           (public-string)
 185           (char-code 0)
 186           (check-count 0)
 187           (ignore-count 0)
 188           (reference-save-state)
 189           (prefp)
 190           (entityp)
 191           (pentityp)
 192           (prev-state)
 193           (ch))
 194       (loop
 195         (setq ch (get-next-char tokenbuf))
 196         (when *debug-dtd*
 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)))
 201         (if* (null ch)
 202            then (setf prev-state state)
 203                 (setf state :eof)
 204                 (return)                ;; eof -- exit loop
 205                 )
 206
 207         (case state
 208           (#.state-dtdstart
 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)
 216               else (dotimes (i 15)
 217                      (add-to-coll coll ch)
 218                      (setq ch (get-next-char tokenbuf))
 219                      (if* (null ch)
 220                         then (return)))
 221                    (xml-error (concatenate 'string
 222                                 "illegal DTD characters, starting at: '"
 223                                 (compute-coll-string coll)
 224                                 "'"))
 225                    ))
 226           (#.state-dtd-!-include3
 227            (if* (eq #\] ch) then (setf state state-dtd-!-include4)
 228               else
 229                    (dotimes (i 15)
 230                      (add-to-coll coll ch)
 231                      (setq ch (get-next-char tokenbuf))
 232                      (if* (null ch)
 233                         then (return)))
 234                    (xml-error (concatenate 'string
 235                                 "illegal DTD token, starting at: ']"
 236                                 (compute-coll-string coll)
 237                                 "'"))))
 238           (#.state-dtd-!-include4
 239            (if* (eq #\> ch) then (return)
 240                 else
 241                    (dotimes (i 15)
 242                      (add-to-coll coll ch)
 243                      (setq ch (get-next-char tokenbuf))
 244                      (if* (null ch)
 245                         then (return)))
 246                    (xml-error (concatenate 'string
 247                                 "illegal DTD token, starting at: ']]"
 248                                 (compute-coll-string coll)
 249                                 "'"))))
 250           #+ignore
 251           (#.state-dtd-pref
 252            (if* (xml-name-start-char-p ch) then
 253                    (add-to-coll coll ch)
 254                    (setf state state-dtd-pref2)
 255               else (dotimes (i 15)
 256                      (add-to-coll coll ch)
 257                      (setq ch (get-next-char tokenbuf))
 258                      (if* (null ch)
 259                         then (return)))
 260                    (xml-error (concatenate 'string
 261                                 "illegal DTD parameter reference name, starting at: '"
 262                                 (compute-coll-string coll)
 263                                 "'"))
 264                    ))
 265           (#.state-tokenstart
 266            (if* (eq #\? ch) then (setf state state-dtd-?)
 267             elseif (eq #\! ch) then (setf state state-dtd-!)
 268               else (dotimes (i 15)
 269                      (add-to-coll coll ch)
 270                      (setq ch (get-next-char tokenbuf))
 271                      (if* (null ch)
 272                         then (return)))
 273                    (xml-error (concatenate 'string
 274                                 "illegal DTD characters, starting at: '<"
 275                                 (compute-coll-string coll)
 276                                 "'"))
 277                    ))
 278           (#.state-dtd-?
 279            (if* (xml-name-char-p ch)
 280               then
 281                    (add-to-coll coll ch)
 282             elseif (and external (eq #\% ch)) then
 283                    (external-param-reference tokenbuf coll external-callback)
 284               else
 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) "'"))
 290                      )
 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)))
 300                       then
 301                            (xml-error "<?xml not allowed in dtd")
 302                       else
 303                            (setq tag-to-return (compute-tag coll))
 304                            (setf state state-dtd-?-2))
 305                    (clear-coll coll)))
 306           (#.state-dtd-?-2
 307            (if* (xml-space-p ch)
 308               then nil
 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)))
 315           (#.state-dtd-?-3
 316            (if* (eq #\? ch)
 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)))
 321           (#.state-dtd-?-4
 322            (if* (eq #\> ch)
 323               then
 324                    (push (compute-coll-string coll) contents-to-return)
 325                    (clear-coll coll)
 326                    (return)
 327               else (setf state state-dtd-?-3)
 328                    (add-to-coll coll #\?)
 329                    (add-to-coll coll ch)))
 330           (#.state-dtd-!
 331            (if* (eq #\- ch) then (setf state state-dtd-comment)
 332             elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-token)
 333                    (un-next-char ch)
 334             elseif (and (eq #\[ ch) external) then
 335                    (setf state state-dtd-!-cond)
 336               else (dotimes (i 15)
 337                      (add-to-coll coll ch)
 338                      (setq ch (get-next-char tokenbuf))
 339                      (if* (null ch)
 340                         then (return)))
 341                    (xml-error (concatenate 'string
 342                                 "illegal DTD characters, starting at: '<!"
 343                                 (compute-coll-string coll)
 344                                 "'"))
 345                    ))
 346           (#.state-dtd-!-cond
 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")
 352                    ))
 353           (#.state-dtd-!-cond2
 354            (if* (eq #\N ch) then (setf state state-dtd-!-include)
 355                    (setf check-count 2)
 356             elseif (eq #\G ch) then (setf state state-dtd-!-ignore)
 357                    (setf check-count 2)
 358               else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
 359                    ))
 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
 364                    (incf check-count)
 365               else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
 366                    ))
 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)
 372                    (incf ignore-count)
 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
 399                    (incf check-count)
 400               else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
 401                    ))
 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'")))
 408           (#.state-dtd-comment
 409            (if* (eq #\- ch)
 410               then (setf state state-dtd-comment2)
 411                    (setf tag-to-return :comment)
 412               else (clear-coll coll)
 413                    (dotimes (i 15)
 414                      (add-to-coll coll ch)
 415                      (setq ch (get-next-char tokenbuf))
 416                      (if* (null ch)
 417                         then (return)))
 418                    (xml-error (concatenate 'string
 419                                 "illegal token following '<![-', starting at '<!-"
 420                                 (compute-coll-string coll)
 421                                 "'"))
 422                    ))
 423           (#.state-dtd-comment2
 424            (if* (eq #\- ch)
 425               then (setf state state-dtd-comment3)
 426               else (add-to-coll coll ch)))
 427           (#.state-dtd-comment3
 428            (if* (eq #\- ch)
 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
 433            (if* (eq #\> ch)
 434               then (push (compute-coll-string coll) contents-to-return)
 435                    (clear-coll coll)
 436                    (return)
 437               else  (clear-coll coll)
 438                    (dotimes (i 15)
 439                      (add-to-coll coll ch)
 440                      (setq ch (get-next-char tokenbuf))
 441                      (if* (null ch)
 442                         then (return)))
 443                    (xml-error (concatenate 'string
 444                                 "illegal token following '--' comment terminator, starting at '--"
 445                                 (compute-coll-string coll)
 446                                 "'"))
 447                    ))
 448           (#.state-dtd-!-token
 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))
 454                    (clear-coll 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
 459                            (setf entityp t)
 460                            (setf state state-dtd-!-entity)
 461                     elseif (eq tag-to-return :NOTATION) then
 462                            (setf state state-dtd-!-notation)
 463                       else
 464                            (xml-error (concatenate 'string
 465                                         "illegal DTD characters, starting at: '<!"
 466                                         (string tag-to-return)
 467                                         "'")))
 468               else (dotimes (i 15)
 469                      (add-to-coll coll ch)
 470                      (setq ch (get-next-char tokenbuf))
 471                      (if* (null ch)
 472                         then (return)))
 473                    (xml-error (concatenate 'string
 474                                 "illegal DTD characters, starting at: '<!"
 475                                 (compute-coll-string coll)
 476                                 "'"))
 477                    ))
 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)
 485               else (dotimes (i 15)
 486                      (add-to-coll coll ch)
 487                      (setq ch (get-next-char tokenbuf))
 488                      (if* (null ch)
 489                         then (return)))
 490                    (xml-error (concatenate 'string
 491                                 "illegal DTD characters, starting at: '<!NOTATION "
 492                                 (compute-coll-string coll)
 493                                 "'"))
 494                    ))
 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)
 501                    (clear-coll coll)
 502                    (setf state state-dtd-!-notation3)
 503               else (dotimes (i 15)
 504                      (add-to-coll coll ch)
 505                      (setq ch (get-next-char tokenbuf))
 506                      (if* (null ch)
 507                         then (return)))
 508                    (xml-error (concatenate 'string
 509                                 "illegal DTD <!NOTATION name: "
 510                                 (compute-coll-string coll)
 511                                 "'"))
 512                    ))
 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)
 520               else (dotimes (i 15)
 521                      (add-to-coll coll ch)
 522                      (setq ch (get-next-char tokenbuf))
 523                      (if* (null ch)
 524                         then (return)))
 525                    (xml-error (concatenate 'string
 526                                 "illegal DTD <!NOTATION spec for "
 527                                 (string (first contents-to-return))
 528                                 ": '"
 529                                 (compute-coll-string coll)
 530                                 "'"))
 531                    ))
 532           (#.state-dtd-!-entity
 533            (if* (eq #\% ch) then (push :param contents-to-return)
 534                    (setf pentityp t)
 535                    (setf state state-dtd-!-entity2)
 536             elseif (xml-name-start-char-p ch) then
 537                    (add-to-coll coll ch)
 538                    (setf pending nil)
 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)
 543               else (dotimes (i 15)
 544                      (add-to-coll coll ch)
 545                      (setq ch (get-next-char tokenbuf))
 546                      (if* (null ch)
 547                         then (return)))
 548                    (xml-error (concatenate 'string
 549                                 "illegal DTD characters, starting at: '<!ENTITY "
 550                                 (compute-coll-string coll)
 551                                 "'"))
 552                    ))
 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)
 557               else (dotimes (i 15)
 558                      (add-to-coll coll ch)
 559                      (setq ch (get-next-char tokenbuf))
 560                      (if* (null ch)
 561                         then (return)))
 562                    (xml-error (concatenate 'string
 563                                 "illegal DTD <!ENTITY spec for "
 564                                 (string (first contents-to-return))
 565                                 ": '"
 566                                 (compute-coll-string coll)
 567                                 "'"))
 568                    ))
 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))
 577                    (clear-coll coll)
 578                    (setf state state-dtd-!-entity4)
 579               else (dotimes (i 15)
 580                      (add-to-coll coll ch)
 581                      (setq ch (get-next-char tokenbuf))
 582                      (if* (null ch)
 583                         then (return)))
 584                    (xml-error (concatenate 'string
 585                                 "illegal DTD <!ENTITY name: "
 586                                 (compute-coll-string coll)
 587                                 "'"))
 588                    ))
 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)
 599               else (dotimes (i 15)
 600                      (add-to-coll coll ch)
 601                      (setq ch (get-next-char tokenbuf))
 602                      (if* (null ch)
 603                         then (return)))
 604                    (xml-error (concatenate 'string
 605                                 "illegal DTD <!ENTITY spec: '"
 606                                 (compute-coll-string coll)
 607                                 "'"))
 608                    ))
 609           (#.state-dtd-!-entity6
 610            (if* (xml-name-char-p ch) ;; starting char already passed more restrictive test
 611               then
 612                    (add-to-coll coll ch)
 613             elseif (and external (eq #\% ch)) then
 614                    (external-param-reference tokenbuf coll external-callback)
 615               else
 616                    (when (not (xml-space-p ch))
 617                      (dotimes (i 15)
 618                        (add-to-coll coll ch)
 619                        (setq ch (get-next-char tokenbuf))
 620                        (if* (null ch)
 621                           then (return)))
 622                      (xml-error
 623                       (concatenate 'string
 624                         "illegal character in '"
 625                         (compute-coll-string coll)
 626                         "' in <! tag: " (string tag-to-return) " "
 627                         (string (first contents-to-return))
 628                       ))
 629                      )
 630                    (let ((token (compute-tag coll)))
 631                      (push token contents-to-return)
 632                      (clear-coll coll)
 633                      (if* (eq :SYSTEM token) then (setf state state-!-dtd-system)
 634                       elseif (eq :PUBLIC token) then (setf state state-!-dtd-public)
 635                         else (xml-error
 636                               (concatenate 'string
 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))))
 641                              )
 642                      )))
 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)
 650               else (dotimes (i 15)
 651                      (add-to-coll coll ch)
 652                      (setq ch (get-next-char tokenbuf))
 653                      (if* (null ch)
 654                         then (return)))
 655                    (xml-error (concatenate 'string
 656                                 "illegal DTD <!ENTITY % name: "
 657                                 (compute-coll-string coll)
 658                                 "'"))
 659                    ))
 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)
 667               else (xml-error
 668                     (concatenate 'string
 669                       "expected quote or double-quote got: '"
 670                       (string ch)
 671                       "' in <! tag: " (string tag-to-return) " "
 672                       (string (second contents-to-return)) " "
 673                       (string (first contents-to-return))
 674                       ))))
 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)
 680                    (clear-coll coll)
 681                    (setf state state-!-dtd-public3)
 682             elseif (pub-id-char-p ch) then (add-to-coll coll ch)
 683               else (dotimes (i 15)
 684                      (add-to-coll coll ch)
 685                      (setq ch (get-next-char tokenbuf))
 686                      (if* (null ch)
 687                         then (return)))
 688                    (xml-error
 689                     (concatenate 'string
 690                       "illegal character in string: '"
 691                       (compute-coll-string coll) "'"))
 692                    ))
 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)
 698                         (eq #\> ch)) then
 699                    (setf state state-!-dtd-system)
 700                    (return)
 701               else
 702                    (dotimes (i 15)
 703                      (add-to-coll coll ch)
 704                      (setq ch (get-next-char tokenbuf))
 705                      (if* (null ch)
 706                         then (return)))
 707                    (xml-error
 708                     (concatenate 'string
 709                       "Expected space before: '"
 710                       (compute-coll-string coll) "'"))
 711                    ))
 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)
 721               else (xml-error
 722                     (concatenate 'string
 723                       "expected quote or double-quote got: '"
 724                       (string ch)
 725                       "' in <! tag: " (string tag-to-return) " "
 726                       (string (second contents-to-return)) " "
 727                       (string (first contents-to-return))
 728                       ))))
 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)))
 735                      (if* pentityp then
 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)
 739                                                             tag-to-return
 740                                                             public-string)
 741                                         (iostruct-parameter-entities tokenbuf)))
 742                                )
 743                         else
 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)
 747                                                             tag-to-return
 748                                                             public-string
 749                                                             )
 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)
 754                                                             tag-to-return
 755                                                             public-string
 756                                                             )
 757                                         (iostruct-general-entities tokenbuf))))
 758                                )
 759                              )
 760                      (push system-string contents-to-return))
 761                    (clear-coll coll)
 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)
 769               else
 770                    (dotimes (i 15)
 771                      (add-to-coll coll ch)
 772                      (setq ch (get-next-char tokenbuf))
 773                      (if* (null ch)
 774                         then (return)))
 775                    (xml-error (concatenate 'string
 776                                 "illegal DTD <!ENTITY value for "
 777                                 (string (first (nreverse contents-to-return)))
 778                                 ": '"
 779                                 (compute-coll-string coll)
 780                                 "'"))
 781                    ))
 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)
 790               else (dotimes (i 15)
 791                      (add-to-coll coll ch)
 792                      (setq ch (get-next-char tokenbuf))
 793                      (if* (null ch)
 794                         then (return)))
 795                    (xml-error (concatenate 'string
 796                                 "illegal DTD <!ENTITY value for "
 797                                 (string (first (nreverse contents-to-return)))
 798                                 ": '"
 799                                 (compute-coll-string coll)
 800                                 "'"))
 801                    ))
 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))
 810                        (dotimes (i 15)
 811                          (add-to-coll coll ch)
 812                          (setq ch (get-next-char tokenbuf))
 813                          (if* (null ch)
 814                             then (return)))
 815                        (xml-error (concatenate 'string
 816                                     "illegal DTD <!ENTITY value for "
 817                                     (string (first (nreverse contents-to-return)))
 818                                     ": '"
 819                                     (compute-coll-string coll)
 820                                     "'"))
 821                        )
 822                      (clear-coll coll)
 823                      (push token contents-to-return)
 824                      (setf state state-!-dtd-system6))
 825               else (dotimes (i 15)
 826                      (add-to-coll coll ch)
 827                      (setq ch (get-next-char tokenbuf))
 828                      (if* (null ch)
 829                         then (return)))
 830                    (xml-error (concatenate 'string
 831                                 "illegal DTD <!ENTITY value for "
 832                                 (string (first (nreverse contents-to-return)))
 833                                 ": '"
 834                                 (compute-coll-string coll)
 835                                 "'"))
 836                    ))
 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)
 844               else (dotimes (i 15)
 845                      (add-to-coll coll ch)
 846                      (setq ch (get-next-char tokenbuf))
 847                      (if* (null ch)
 848                         then (return)))
 849                    (xml-error (concatenate 'string
 850                                 "illegal DTD <!ENTITY value for "
 851                                 (string (first (nreverse contents-to-return)))
 852                                 ": '"
 853                                 (compute-coll-string coll)
 854                                 "'"))
 855                    ))
 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)
 863                    (clear-coll coll)
 864                    (setf state state-dtd-!-entity5) ;; just looking for space, >
 865             elseif (eq #\> ch) then
 866                    (push (compute-tag coll) contents-to-return)
 867                    (clear-coll coll)
 868                    (return)
 869               else (dotimes (i 15)
 870                      (add-to-coll coll ch)
 871                      (setq ch (get-next-char tokenbuf))
 872                      (if* (null ch)
 873                         then (return)))
 874                    (xml-error (concatenate 'string
 875                                 "illegal DTD <!ENTITY value for "
 876                                 (string (first (nreverse contents-to-return)))
 877                                 ": '"
 878                                 (compute-coll-string coll)
 879                                 "'"))
 880                    ))
 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)))
 886                        (push tmp 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)
 892                    (clear-coll coll)
 893                    (if* pentityp then
 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))))
 900                       else
 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
 911                    (setf prefp t)
 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)
 916               else (dotimes (i 15)
 917                      (add-to-coll coll ch)
 918                      (setq ch (get-next-char tokenbuf))
 919                      (if* (null ch)
 920                         then (return)))
 921                    (xml-error (concatenate 'string
 922                                 "illegal DTD <!ENTITY value for "
 923                                 (string (first contents-to-return))
 924                                 ": '"
 925                                 (compute-coll-string coll)
 926                                 "'"))
 927                    ))
 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)
 934                    (dotimes (i 15)
 935                      (add-to-coll coll ch)
 936                      (setq ch (get-next-char tokenbuf))
 937                      (if* (null ch)
 938                         then (return)))
 939                    (xml-error (concatenate 'string
 940                                 "illegal DTD contents following <!ENTITY spec for "
 941                                 (string (first contents-to-return))
 942                                 ": '"
 943                                 (compute-coll-string coll)
 944                                 "'"))
 945                    ))
 946           (#.state-dtd-!-attlist
 947            (if* (xml-name-start-char-p ch) then (setf state state-dtd-!-attlist-name)
 948                    (un-next-char ch)
 949             elseif (xml-space-p ch) then nil
 950             elseif (and external (eq #\% ch)) then
 951                    (external-param-reference tokenbuf coll external-callback)
 952               else (dotimes (i 15)
 953                      (add-to-coll coll ch)
 954                      (setq ch (get-next-char tokenbuf))
 955                      (if* (null ch)
 956                         then (return)))
 957                    (xml-error (concatenate 'string
 958                                 "illegal DTD characters, starting at: '<!ATTLIST "
 959                                 (compute-coll-string coll)
 960                                 "'"))))
 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*)
 967                          contents-to-return)
 968                    (clear-coll coll)
 969                    (setf state state-dtd-!-attdef)
 970             elseif (eq #\> ch) then
 971                    (push (compute-tag coll *package*)
 972                          contents-to-return)
 973                    (clear-coll coll)
 974                    (return)
 975               else (push (compute-tag coll)
 976                          contents-to-return)
 977                    (clear-coll coll)
 978                    (dotimes (i 15)
 979                      (add-to-coll coll ch)
 980                      (setq ch (get-next-char tokenbuf))
 981                      (if* (null ch)
 982                         then (return)))
 983                    (xml-error (concatenate 'string
 984                                 "illegal DTD <!ATTLIST content spec for "
 985                                 (string (first contents-to-return))
 986                                 ": '"
 987                                 (compute-coll-string coll)
 988                                 "'"))
 989                    ))
 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
 995                    (un-next-char ch)
 996                    (setf state state-dtd-!-attdef-name)
 997             elseif (eq #\> ch) then (return)
 998               else (dotimes (i 15)
 999                      (add-to-coll coll ch)
1000                      (setq ch (get-next-char tokenbuf))
1001                      (if* (null ch)
1002                         then (return)))
1003                    (xml-error (concatenate 'string
1004                                 "illegal DTD <!ATTLIST content spec for "
1005                                 (string (first contents-to-return))
1006                                 ": '"
1007                                 (compute-coll-string coll)
1008                                 "'"))
1009                    ))
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*))
1016                    (clear-coll coll)
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))
1021                      (if* (null ch)
1022                         then (return)))
1023                    (xml-error (concatenate 'string
1024                                 "illegal DTD <!ATTLIST type spec for "
1025                                 (string (first contents-to-return))
1026                                 ": '"
1027                                 (compute-coll-string coll)
1028                                 "'"))
1029                    ))
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)))
1056                        (dotimes (i 15)
1057                          (add-to-coll coll ch)
1058                          (setq ch (get-next-char tokenbuf))
1059                          (if* (null ch)
1060                             then (return)))
1061                        (xml-error (concatenate 'string
1062                                     "illegal DTD <!ATTLIST type spec for "
1063                                     (string (first contents-to-return))
1064                                     ": '"
1065                                     (compute-coll-string coll)
1066                                     "'")))
1067                      (if* (eq token :NOTATION) then
1068                              (push (list token) pending)
1069                              (setf state state-dtd-!-attdef-notation)
1070                         else
1071                              (push token pending)
1072                              (setf state state-dtd-!-attdef-decl))
1073                      )
1074                    (clear-coll coll)
1075               else (dotimes (i 15)
1076                      (add-to-coll coll ch)
1077                      (setq ch (get-next-char tokenbuf))
1078                      (if* (null ch)
1079                         then (return)))
1080                    (xml-error (concatenate 'string
1081                                 "illegal DTD <!ATTLIST type spec for "
1082                                 (string (first contents-to-return))
1083                                 ": '"
1084                                 (compute-coll-string coll)
1085                                 "'"))
1086                    ))
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))
1095                      (if* (null ch)
1096                         then (return)))
1097                    (xml-error (concatenate 'string
1098                                 "illegal DTD <!ATTLIST type spec for "
1099                                 (string (first contents-to-return))
1100                                 ": '"
1101                                 (compute-coll-string coll)
1102                                 "'"))
1103                    ))
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))
1118                      (if* (null ch)
1119                         then (return)))
1120                    (xml-error (concatenate 'string
1121                                 "illegal DTD <!ATTLIST type spec for "
1122                                 (string (first contents-to-return))
1123                                 ": '"
1124                                 (compute-coll-string coll)
1125                                 "'"))
1126                    ))
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))
1135                    (clear-coll coll)
1136                    (setf state state-dtd-!-attdef-notation4)
1137             elseif (eq #\| ch) then
1138                    (push (compute-tag coll) (first pending))
1139                    (clear-coll coll)
1140                    (setf state state-dtd-!-attdef-notation2)
1141             elseif (eq #\) ch) then
1142                    (push (compute-tag coll) (first pending))
1143                    (clear-coll coll)
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))
1150                      (if* (null ch)
1151                         then (return)))
1152                    (xml-error (concatenate 'string
1153                                 "illegal DTD <!ATTLIST type spec for "
1154                                 (string (first contents-to-return))
1155                                 ": '"
1156                                 (compute-coll-string coll)
1157                                 "'"))
1158                    ))
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)
1163               else
1164                    (dotimes (i 15)
1165                      (add-to-coll coll ch)
1166                      (setq ch (get-next-char tokenbuf))
1167                      (if* (null ch)
1168                         then (return)))
1169                    (xml-error
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))
1185                      (if* (null ch)
1186                         then (return)))
1187                    (xml-error (concatenate 'string
1188                                 "illegal DTD <!ATTLIST type spec for "
1189                                 (string (first contents-to-return))
1190                                 ": '"
1191                                 (compute-coll-string coll)
1192                                 "'"))
1193                    ))
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))
1206                      (if* (null ch)
1207                         then (return)))
1208                    (xml-error (concatenate 'string
1209                                 "illegal DTD <!ATTLIST type spec for "
1210                                 (string (first contents-to-return))
1211                                 ": '"
1212                                 (compute-coll-string coll)
1213                                 "'"))
1214                    ))
1215           (#.state-dtd-!-attdef-decl-value
1216            (if* (eq ch value-delim) then
1217                    #-ignore
1218                    (push (first (parse-default-value (list (compute-coll-string coll))
1219                                               tokenbuf external-callback))
1220                          pending)
1221                    #+ignore
1222                    (push (compute-coll-string coll) pending)
1223                    (setf contents-to-return
1224                      (append contents-to-return
1225                              (if* entityp then
1226                                     (nreverse pending)
1227                                 else (list (nreverse pending)))))
1228                    (setf pending (list nil))
1229                    (setf state state-dtd-!-attdef)
1230                    (clear-coll coll)
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))
1238                      (if* (null ch)
1239                         then (return)))
1240                    (xml-error (concatenate 'string
1241                                 "illegal DTD <!ATTLIST type spec for "
1242                                 (string (first contents-to-return))
1243                                 ": '"
1244                                 (compute-coll-string coll)
1245                                 "'"))
1246                    ))
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 #\&))
1253                    (un-next-char ch)
1254               else (clear-coll coll)
1255                    (dotimes (i 15)
1256                      (add-to-coll coll ch)
1257                      (setq ch (get-next-char tokenbuf))
1258                      (if* (null ch)
1259                         then (return)))
1260                    (xml-error (concatenate 'string
1261                                 "illegal reference name, starting at: '&"
1262                                 (compute-coll-string coll)
1263                                 "'"))))
1264           (#.state-dtd-!-attdef-decl-value4
1265            (if* (eq #\x ch)
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)
1269                    (un-next-char ch)
1270               else (clear-coll coll)
1271                    (dotimes (i 15)
1272                      (add-to-coll coll ch)
1273                      (setq ch (get-next-char tokenbuf))
1274                      (if* (null ch)
1275                         then (return)))
1276                    (xml-error (concatenate 'string
1277                                 "illegal character reference code, starting at: '&#"
1278                                 (compute-coll-string coll)
1279                                 "'"))
1280                    ))
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))
1285             elseif (eq #\; ch)
1286               then
1287                    (if* (not prefp) then (add-to-coll coll ch)
1288                     elseif (not external) then
1289                            (xml-error
1290                             (concatenate 'string
1291                               "internal dtd subset cannot reference parameter entity within a token; entity: "
1292                               (compute-coll-string entity)))
1293                       else
1294                            (let* ((entity-symbol (compute-tag entity))
1295                                   (p-value
1296                                    (assoc entity-symbol (iostruct-parameter-entities tokenbuf))))
1297                              (clear-coll entity)
1298                              (if* (and (iostruct-do-entity tokenbuf)
1299                                        (setf p-value
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
1305                                                       "entity:"
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)))
1312                                       elseif p-value then
1313                                              (if* (null external-callback) then
1314                                                      (setf (iostruct-do-entity tokenbuf) nil)
1315                                                 else
1316                                                      (let ((count 0) (string "<?xml ") last-ch
1317                                                            save-ch save-unget
1318                                                            (tmp-count 0)
1319                                                            (entity-stream
1320                                                             (apply external-callback p-value)))
1321                                                        (when entity-stream
1322                                                          (let ((tmp-buf (get-tokenbuf)))
1323                                                            (setf (tokenbuf-stream tmp-buf)
1324                                                              entity-stream)
1325                                                            (setf save-unget
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)
1332                                                            (loop
1333                                                              (let ((cch
1334                                                                     (if* save-ch
1335                                                                        then
1336                                                                             (let ((s2 save-ch))
1337                                                                               (setf save-ch nil)
1338                                                                               s2)
1339                                                                        else
1340                                                                             (next-char
1341                                                                              tmp-buf
1342                                                                              (iostruct-read-sequence-func
1343                                                                               tokenbuf)))))
1344                                                                (when (null cch) (return))
1345                                                                (when *debug-dtd*
1346                                                                  (format t "dtd-char: ~s~%" cch))
1347                                                                (if* (< count 0) then
1348                                                                        (if* (and (eq last-ch #\?)
1349                                                                                  (eq cch #\>)) then
1350                                                                                (setf count 6)
1351                                                                           else (setf last-ch cch))
1352                                                                 elseif (< count 6) then
1353                                                                        (when (and (= count 5)
1354                                                                                (xml-space-p cch))
1355                                                                          (setf cch #\space))
1356                                                                        (if* (not (eq cch
1357                                                                                     (schar string count)
1358                                                                                     )) then
1359                                                                                (loop
1360                                                                                  (when (= tmp-count count)
1361                                                                                    (return))
1362                                                                                  (add-to-coll coll
1363                                                                                               (schar string
1364                                                                                                      tmp-count))
1365                                                                                  (incf tmp-count))
1366                                                                                (add-to-coll coll cch)
1367                                                                                (setf count 10)
1368                                                                           else (incf count))
1369                                                                 elseif (= count 6) then
1370                                                                        (dotimes (i 6)
1371                                                                          (add-to-coll coll (schar string i)))
1372                                                                        (setf count 10)
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)))))
1378                                              )
1379                                      (setf state state-dtdstart)
1380                                 else nil
1381                                      )))
1382                    (setf state reference-save-state)
1383               else (let ((tmp (compute-coll-string entity)))
1384                      (clear-coll coll)
1385                      (dotimes (i 15)
1386                        (add-to-coll coll ch)
1387                        (setq ch (get-next-char tokenbuf))
1388                        (if* (null ch)
1389                           then (return)))
1390                      (xml-error (concatenate 'string
1391                                   "reference not terminated by ';', starting at: '&"
1392                                   tmp
1393                                   (compute-coll-string coll)
1394                                   "'")))
1395                    ))
1396           (#.state-dtd-!-attdef-decl-value6
1397            (let ((code (char-code ch)))
1398              (if* (eq #\; ch)
1399                 then (add-to-coll coll (code-char char-code))
1400                      (setf char-code 0)
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)
1409                      (dotimes (i 15)
1410                        (add-to-coll coll ch)
1411                        (setq ch (get-next-char tokenbuf))
1412                        (if* (null ch)
1413                           then (return)))
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)))
1419                      )))
1420           (#.state-dtd-!-attdef-decl-value7
1421            (let ((code (char-code ch)))
1422              (if* (eq #\; ch)
1423                 then (add-to-coll coll (code-char char-code))
1424                      (setf char-code 0)
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)
1429                      (dotimes (i 15)
1430                        (add-to-coll coll ch)
1431                        (setq ch (get-next-char tokenbuf))
1432                        (if* (null ch)
1433                           then (return)))
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)))
1439                      )))
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)))
1449                        (dotimes (i 15)
1450                          (add-to-coll coll ch)
1451                          (setq ch (get-next-char tokenbuf))
1452                          (if* (null ch)
1453                             then (return)))
1454                        (xml-error (concatenate 'string
1455                                     "illegal DTD <!ATTLIST type spec for "
1456                                     (string (first contents-to-return))
1457                                     ": '"
1458                                     (compute-coll-string coll)
1459                                     "'")))
1460                      (push token pending)
1461                      (if* (eq :FIXED token) then
1462                              (when (eq #\> ch)
1463                                (dotimes (i 15)
1464                                  (add-to-coll coll ch)
1465                                  (setq ch (get-next-char tokenbuf))
1466                                  (if* (null ch)
1467                                     then (return)))
1468                                (xml-error (concatenate 'string
1469                                             "illegal DTD <!ATTLIST type spec for "
1470                                             (string (first contents-to-return))
1471                                             ": '"
1472                                             (compute-coll-string coll)
1473                                             "'")))
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))))
1478                              (return)
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)))
1483                    (clear-coll coll)
1484               else (dotimes (i 15)
1485                      (add-to-coll coll ch)
1486                      (setq ch (get-next-char tokenbuf))
1487                      (if* (null ch)
1488                         then (return)))
1489                    (xml-error (concatenate 'string
1490                                 "illegal DTD <!ATTLIST type spec for "
1491                                 (string (first contents-to-return))
1492                                 ": '"
1493                                 (compute-coll-string coll)
1494                                 "'"))
1495                    ))
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))
1506                      (if* (null ch)
1507                         then (return)))
1508                    (xml-error (concatenate 'string
1509                                 "illegal DTD <!ATTLIST type spec for "
1510                                 (string (first contents-to-return))
1511                                 ": '"
1512                                 (compute-coll-string coll)
1513                                 "'"))
1514                       ))
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)
1520                    (un-next-char ch)
1521               else (dotimes (i 15)
1522                      (add-to-coll coll ch)
1523                      (setq ch (get-next-char tokenbuf))
1524                      (if* (null ch)
1525                         then (return)))
1526                    (xml-error (concatenate 'string
1527                                 "illegal DTD characters, starting at: '<!ELEMENT "
1528                                 (compute-coll-string coll)
1529                                 "'"))))
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)
1536                          contents-to-return)
1537                    (clear-coll 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))
1542                      (if* (null ch)
1543                         then (return)))
1544                    (xml-error (concatenate 'string
1545                                 "illegal DTD <!ELEMENT name: '"
1546                                 (compute-coll-string coll)
1547                                 "'"))
1548                    ))
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
1555                    (un-next-char ch)
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))
1560                      (if* (null ch)
1561                         then (return)))
1562                    (xml-error (concatenate 'string
1563                                 "illegal DTD <!ELEMENT content spec for "
1564                                 (string (first contents-to-return))
1565                                 ": '"
1566                                 (compute-coll-string coll)
1567                                 "'"))
1568                    ))
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
1574                    (un-next-char ch)
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
1579                    (push nil pending)
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))
1584                      (if* (null ch)
1585                         then (return)))
1586                    (xml-error (concatenate 'string
1587                                 "illegal DTD <!ELEMENT content spec for "
1588                                 (string (first contents-to-return))
1589                                 ": '"
1590                                 (compute-coll-string coll)
1591                                 "'"))))
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)))
1596                    (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))
1642                      (if* (null ch)
1643                         then (return)))
1644                    (xml-error (concatenate 'string
1645                                 "illegal DTD <!ELEMENT content spec for "
1646                                 (string (first (reverse contents-to-return)))
1647                                 ": '"
1648                                 (compute-coll-string coll)
1649                                 "'"))
1650                    ))
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))
1657                    (clear-coll coll)
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))))
1663                    (clear-coll coll)
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))))
1669                    (clear-coll coll)
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))))
1675                    (clear-coll coll)
1676                    (setf state state-dtd-!-element-type-paren-name2)
1677             elseif (eq #\) ch) then
1678                    (push (compute-tag coll) (first pending))
1679                    (clear-coll coll)
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)
1689                            )
1690             elseif (eq #\, ch) then
1691                    (when (and (first pending) (not (eq :seq (first pending-type))))
1692                      (clear-coll coll)
1693                      (dotimes (i 15)
1694                        (add-to-coll coll ch)
1695                        (setq ch (get-next-char tokenbuf))
1696                        (if* (null ch)
1697                           then (return)))
1698                      (xml-error (concatenate 'string
1699                                 "illegal '|' and ',' mix starting at '"
1700                                 (compute-coll-string coll)
1701                                 "'")))
1702                    (push (compute-tag coll) (first pending))
1703                    (push :seq pending-type)
1704                    (clear-coll coll)
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))))
1708                      (clear-coll coll)
1709                      (dotimes (i 15)
1710                        (add-to-coll coll ch)
1711                        (setq ch (get-next-char tokenbuf))
1712                        (if* (null ch)
1713                           then (return)))
1714                      (xml-error (concatenate 'string
1715                                 "illegal '|' and ',' mix starting at '"
1716                                 (compute-coll-string coll)
1717                                 "'")))
1718                    (push (compute-tag coll) (first pending))
1719                    (push :choice pending-type)
1720                    (clear-coll coll)
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))
1725                      (if* (null ch)
1726                         then (return)))
1727                    (xml-error (concatenate 'string
1728                                 "illegal DTD <!ELEMENT content spec for "
1729                                 (string (first contents-to-return))
1730                                 ": '"
1731                                 (compute-coll-string coll)
1732                                 "'"))
1733                    ))
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))))
1740                      (clear-coll coll)
1741                      (dotimes (i 15)
1742                        (add-to-coll coll ch)
1743                        (setq ch (get-next-char tokenbuf))
1744                        (if* (null ch)
1745                           then (return)))
1746                      (xml-error (concatenate 'string
1747                                 "illegal '|' and ',' mix starting at '"
1748                                 (compute-coll-string coll)
1749                                 "'")))
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))))
1754                      (clear-coll coll)
1755                      (dotimes (i 15)
1756                        (add-to-coll coll ch)
1757                        (setq ch (get-next-char tokenbuf))
1758                        (if* (null ch)
1759                           then (return)))
1760                      (xml-error (concatenate 'string
1761                                 "illegal '|' and ',' mix starting at '"
1762                                 (compute-coll-string coll)
1763                                 "'")))
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))))
1771                            )
1772               else (dotimes (i 15)
1773                      (add-to-coll coll ch)
1774                      (setq ch (get-next-char tokenbuf))
1775                      (if* (null ch)
1776                         then (return)))
1777                    (xml-error (concatenate 'string
1778                                 "illegal DTD <!ELEMENT content spec for "
1779                                 (string (first (reverse contents-to-return)))
1780                                 ": '"
1781                                 (compute-coll-string coll)
1782                                 "'"))
1783                    ))
1784
1785           (#.state-dtd-!-element-type-paren-choice
1786            (if* (xml-name-start-char-p ch) then
1787                    (un-next-char ch)
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
1793                    (push nil pending)
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)
1814                            )
1815               else (dotimes (i 15)
1816                      (add-to-coll coll ch)
1817                      (setq ch (get-next-char tokenbuf))
1818                      (if* (null ch)
1819                         then (return)))
1820                    (xml-error (concatenate 'string
1821                                 "illegal DTD <!ELEMENT content spec for "
1822                                 (string (first (reverse contents-to-return)))
1823                                 ": '"
1824                                 (compute-coll-string coll)
1825                                 "'"))
1826                    ))
1827
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)
1831                    (un-next-char ch)
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))
1839                      (if* (null ch)
1840                         then (return)))
1841                    (xml-error (concatenate 'string
1842                                 "illegal DTD <!ELEMENT content spec for "
1843                                 (string (first contents-to-return))
1844                                 ": '"
1845                                 (compute-coll-string coll)
1846                                 "'"))
1847                    ))
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))
1854                    (clear-coll coll)
1855                    (setf state state-dtd-!-element-type-paren-choice-name2)
1856             elseif (eq #\? ch) then
1857                    (push (list :? (compute-tag coll)) (first pending))
1858                    (clear-coll coll)
1859                    (setf state state-dtd-!-element-type-paren-choice-name2)
1860             elseif (eq #\* ch) then
1861                    (push (list :* (compute-tag coll)) (first pending))
1862                    (clear-coll coll)
1863                    (setf state state-dtd-!-element-type-paren-choice-name2)
1864             elseif (eq #\+ ch) then
1865                    (push (list :+ (compute-tag coll)) (first pending))
1866                    (clear-coll coll)
1867                    (setf state state-dtd-!-element-type-paren-choice-name2)
1868             elseif (eq #\) ch) then
1869                    (push (compute-tag coll) (first pending))
1870                    (clear-coll coll)
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
1887                                      ))
1888                            (setf pending (rest pending))
1889                            (setf state state-dtd-!-element-type-paren-choice-name3)
1890                            )
1891             elseif (eq #\, ch) then
1892                    (when (and (first pending) (not (eq :seq (first pending-type))))
1893                      (clear-coll coll)
1894                      (dotimes (i 15)
1895                        (add-to-coll coll ch)
1896                        (setq ch (get-next-char tokenbuf))
1897                        (if* (null ch)
1898                           then (return)))
1899                      (xml-error (concatenate 'string
1900                                 "illegal '|' and ',' mix starting at '"
1901                                 (compute-coll-string coll)
1902                                 "'")))
1903                    (push (compute-tag coll) (first pending))
1904                    (clear-coll coll)
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))))
1909                      (clear-coll coll)
1910                      (dotimes (i 15)
1911                        (add-to-coll coll ch)
1912                        (setq ch (get-next-char tokenbuf))
1913                        (if* (null ch)
1914                           then (return)))
1915                      (xml-error (concatenate 'string
1916                                 "illegal '|' and ',' mix starting at '"
1917                                 (compute-coll-string coll)
1918                                 "'")))
1919                    (push (compute-tag coll) (first pending))
1920                    (clear-coll coll)
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))
1926                      (if* (null ch)
1927                         then (return)))
1928                    (xml-error (concatenate 'string
1929                                 "illegal DTD <!ELEMENT content spec for "
1930                                 (string (first contents-to-return))
1931                                 ": '"
1932                                 (compute-coll-string coll)
1933                                 "'"))
1934                    ))
1935           (#.state-dtd-!-element-type-paren-choice-name2
1936            (if* (eq #\| ch)
1937                    ;; begin changes 2001-03-22
1938               then (setf state state-dtd-!-element-type-paren-choice)
1939                    (push :choice pending-type)
1940             elseif (eq #\, ch)
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)
1963                            )
1964                    (setf pending (rest pending))
1965               else (dotimes (i 15)
1966                      (add-to-coll coll ch)
1967                      (setq ch (get-next-char tokenbuf))
1968                      (if* (null ch)
1969                         then (return)))
1970                    (xml-error (concatenate 'string
1971                                 "illegal DTD <!ELEMENT content spec for "
1972                                 (string (first contents-to-return))
1973                                 ": '"
1974                                 (compute-coll-string coll)
1975                                 "'"))
1976                    ))
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)
2010                            )
2011             elseif (eq #\, ch) then
2012                    (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
2013                      (clear-coll coll)
2014                      (dotimes (i 15)
2015                        (add-to-coll coll ch)
2016                        (setq ch (get-next-char tokenbuf))
2017                        (if* (null ch)
2018                           then (return)))
2019                      (xml-error (concatenate 'string
2020                                 "illegal '|' and ',' mix starting at '"
2021                                 (compute-coll-string coll)
2022                                 "'")))
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))))
2027                      (clear-coll coll)
2028                      (dotimes (i 15)
2029                        (add-to-coll coll ch)
2030                        (setq ch (get-next-char tokenbuf))
2031                        (if* (null ch)
2032                           then (return)))
2033                      (xml-error (concatenate 'string
2034                                 "illegal '|' and ',' mix starting at '"
2035                                 (compute-coll-string coll)
2036                                 "'")))
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))
2042                      (if* (null ch)
2043                         then (return)))
2044                    (xml-error (concatenate 'string
2045                                 "illegal DTD <!ELEMENT content spec for "
2046                                 (string (first contents-to-return))
2047                                 ": '"
2048                                 (compute-coll-string coll)
2049                                 "'"))
2050                    ))
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))
2072                      (if* (null ch)
2073                         then (return)))
2074                    (xml-error (concatenate 'string
2075                                 "illegal DTD <!ELEMENT content spec for "
2076                                 (string (first (reverse contents-to-return)))
2077                                 ": '"
2078                                 (compute-coll-string coll)
2079                                 "'"))
2080                    ))
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))
2091                                     ": '"
2092                                     (compute-coll-string coll)
2093                                     "'")))
2094                      (clear-coll 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))
2103                                     ": '"
2104                                     (compute-coll-string coll)
2105                                     "'")))
2106                      (push token contents-to-return))
2107                    (clear-coll coll)
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))
2115                                     ": '"
2116                                     (compute-coll-string coll)
2117                                     "'")))
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))
2123                      (if* (null ch)
2124                         then (return)))
2125                    (xml-error (concatenate 'string
2126                                 "illegal DTD <!ELEMENT content spec for "
2127                                 (string (first contents-to-return))
2128                                 ": '"
2129                                 (compute-coll-string coll)
2130                                 "'"))
2131                    ))
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))
2142                      (if* (null ch)
2143                         then (return)))
2144                    (xml-error (concatenate 'string
2145                                 "illegal DTD <!ELEMENT content spec for "
2146                                 (string (first (reverse contents-to-return)))
2147                                 ": '"
2148                                 (compute-coll-string coll)
2149                                 "'"))
2150                    ))
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
2156                    (un-next-char ch)
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))
2161                      (if* (null ch)
2162                         then (return)))
2163                    (xml-error (concatenate 'string
2164                                 "illegal DTD <!ELEMENT content spec for "
2165                                 (string (first (reverse contents-to-return)))
2166                                 ": '"
2167                                 (compute-coll-string coll)
2168                                 "'"))
2169                    ))
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)
2180                    (dotimes (i 15)
2181                      (add-to-coll coll ch)
2182                      (setq ch (get-next-char tokenbuf))
2183                      (if* (null ch)
2184                         then (return)))
2185                    (xml-error (concatenate 'string
2186                                 "illegal DTD contents following <!ELEMENT content spec for "
2187                                 (string (first (reverse contents-to-return)))
2188                                 ": '"
2189                                 (compute-coll-string coll)
2190                                 "'"))
2191                    ))
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)
2198                    (dotimes (i 15)
2199                      (add-to-coll coll ch)
2200                      (setq ch (get-next-char tokenbuf))
2201                      (if* (null ch)
2202                         then (return)))
2203                    (xml-error (concatenate 'string
2204                                 "illegal DTD contents following <!ELEMENT content spec for "
2205                                 (string (first (reverse contents-to-return)))
2206                                 ": '"
2207                                 (compute-coll-string coll)
2208                                 "'"))
2209                    ))
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)
2216                    (dotimes (i 15)
2217                      (add-to-coll coll ch)
2218                      (setq ch (get-next-char tokenbuf))
2219                      (if* (null ch)
2220                         then (return)))
2221                    (xml-error (concatenate 'string
2222                                 "illegal DTD contents following <!ELEMENT content spec for "
2223                                 (string (first (reverse contents-to-return)))
2224                                 ": '"
2225                                 (compute-coll-string coll)
2226                                 "'"))
2227                    ))
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)))
2235                      (clear-coll 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)))
2243                      (clear-coll 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)
2249                    (dotimes (i 15)
2250                      (add-to-coll coll ch)
2251                      (setq ch (get-next-char tokenbuf))
2252                      (if* (null ch)
2253                         then (return)))
2254                    (xml-error (concatenate 'string
2255                                 "illegal DTD contents in <!ELEMENT content spec for "
2256                                 (string (first (reverse contents-to-return)))
2257                                 ": '"
2258                                 (compute-coll-string coll)
2259                                 "'"))
2260                    ))
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)
2268                    (dotimes (i 15)
2269                      (add-to-coll coll ch)
2270                      (setq ch (get-next-char tokenbuf))
2271                      (if* (null ch)
2272                         then (return)))
2273                    (xml-error (concatenate 'string
2274                                 "illegal DTD contents in <!ELEMENT content spec for "
2275                                 (string (first (reverse contents-to-return)))
2276                                 ": '"
2277                                 (compute-coll-string coll)
2278                                 "'"))
2279                    ))
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)
2289                    (dotimes (i 15)
2290                      (add-to-coll coll ch)
2291                      (setq ch (get-next-char tokenbuf))
2292                      (if* (null ch)
2293                         then (return)))
2294                    (xml-error (concatenate 'string
2295                                 "illegal DTD contents in <!ELEMENT content spec for "
2296                                 (string (first (reverse contents-to-return)))
2297                                 ": '"
2298                                 (compute-coll-string coll)
2299                                 "'"))
2300                    ))
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))
2311                                     ": '"
2312                                     (compute-coll-string coll)
2313                                     "'")))
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))
2322                                     ": '"
2323                                     (compute-coll-string coll)
2324                                     "'")))
2325                      (push token contents-to-return)
2326                      (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))
2331                                 ": '"
2332                                 (compute-coll-string coll)
2333                                 "'"))
2334                    )
2335            )
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 '"
2343                                 (string ch)
2344                                 "' in DTD <! ELEMENT "
2345                                 (string (first contents-to-return))
2346                                 " for "
2347                                 (string (second contents-to-return))))
2348                    ))
2349           (t
2350            (error "need to support dtd state:~s" state))))
2351       (put-back-collector entity)
2352       (put-back-collector coll)
2353       (case state
2354         (#.state-dtdstart
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))
2364                  nil))
2365         ((#.state-dtd-!-attdef-decl-type #.state-dtd-!-attlist-name
2366           #.state-dtd-!-attdef)
2367          (values (append (list tag-to-return) contents-to-return)
2368                  nil))
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
2374           )
2375          (let ((ret (append (list tag-to-return) (nreverse contents-to-return))))
2376            (values ret
2377                    nil)))
2378         #+ignore
2379         (#.state-dtd-pref2
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))
2387         (:eof
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))
2393         (t
2394          (print (list tag-to-return contents-to-return))
2395          (error "need to support dtd <post> state:~s" state)))
2396       )
2397     ))
2398
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)
2403                `(progn
2404                   (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
2405                         (iostruct-entity-bufs tokenbuf))))
2406              (clear-coll (coll)
2407                `(setf (collector-next ,coll) 0))
2408              (un-next-char (ch)
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.)
2415                             ,ch)
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))
2422         (dotimes (i 15)
2423           (add-to-coll coll ch)
2424           (setq ch (get-next-char tokenbuf))
2425           (if* (null ch)
2426              then (return)))
2427         (xml-error (concatenate 'string
2428                      "Illegal DTD parameter entity name starting at: "
2429                      (compute-coll-string coll))))
2430       (loop
2431         (setf ch (get-next-char tokenbuf))
2432         (if* (eq #\; ch) then
2433                 (setf entity-symbol (compute-tag coll))
2434                 (clear-coll 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)
2440                           (setf p-value
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
2446                                        "entity:"
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)
2455                          elseif p-value then
2456                                 (let ((entity-stream (apply external-callback p-value)))
2457                                   (when entity-stream
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 " ")
2462                                       (push entity-buf
2463                                             (iostruct-entity-bufs tokenbuf))
2464                                       (let ((count 0) cch
2465                                             (string "<?xml "))
2466                                         (if* (dotimes (i (length string) t)
2467                                                (setf cch (get-next-char tokenbuf))
2468                                                (when (and (= i 5)
2469                                                           (xml-space-p cch))
2470                                                  (setf cch #\space))
2471                                                (when (not (eq cch
2472                                                               (schar string count)))
2473                                                  (return nil))
2474                                                (incf count)) then
2475                                                 (setf count 5)
2476                                                 (loop
2477                                                   (when (< count 0) (return))
2478                                                   (un-next-char (schar string count))
2479                                                   (decf count))
2480                                                 ;; swallow <?xml token
2481                                                 (next-token tokenbuf external-callback nil)
2482                                            else
2483                                                 (un-next-char cch)
2484                                                 (decf count)
2485                                                 (loop
2486                                                   (when (< count 0) (return))
2487                                                   (un-next-char (schar string count))
2488                                                   (decf count))))
2489                                       (push #\space (iostruct-unget-char tokenbuf))
2490                                       )
2491                                     )))
2492                    else (xml-error
2493                          (concatenate 'string
2494                            (string entity-symbol)
2495                            " parameter entity referenced but not declared"))
2496                         )
2497                 (put-back-collector coll)
2498                 (return)
2499          elseif (xml-name-char-p ch) then (add-to-coll coll ch)
2500            else
2501                 (dotimes (i 15)
2502                   (add-to-coll coll ch)
2503                   (setq ch (get-next-char tokenbuf))
2504                   (if* (null ch)
2505                      then (return)))
2506                 (xml-error (concatenate 'string
2507                              "Illegal DTD parameter entity name stating at: "
2508                              (compute-coll-string coll))))))))
2509
2510