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
  23 (in-package :net.xml.parser)
  24
  25 (pxml-dribble-bug-hook "$Id: pxml3.cl,v 1.2 2003/06/20 02:21:23 kevin Exp $")
  26
  27 (defvar *debug-dtd* nil)
  28
  29 (defun parse-dtd (tokenbuf
  30                   external external-callback)
  31   (declare (optimize (speed 3) (safety 1)))
  32   (let ((guts)
  33         (include-count 0))
  34     (loop
  35       (multiple-value-bind (val kind)
  36           (next-dtd-token tokenbuf
  37                           external include-count external-callback)
  38         (if* (eq kind :end-dtd) then
  39                 (return (nreverse guts))
  40          elseif (eq kind :include) then
  41                 (incf include-count)
  42          elseif (eq kind :ignore) then nil
  43          elseif (eq kind :include-end) then
  44                 (if* (> include-count 0) then (decf include-count)
  45                    else (xml-error "unexpected ']]>' token"))
  46            else (when (iostruct-do-entity tokenbuf) (push val guts)))))))
  47
  48 (defparameter dtd-parser-states ())
  49
  50 (macrolet ((def-dtd-parser-state (var val)
  51                `(progn (eval-when (compile load eval) (defconstant ,var ,val))
  52                        (pushnew '(,val . ,var) dtd-parser-states :key #'car))))
  53   (def-dtd-parser-state state-dtdstart 0)
  54   (def-dtd-parser-state state-tokenstart 1)
  55   (def-dtd-parser-state state-dtd-? 2)
  56   (def-dtd-parser-state state-dtd-! 3)
  57   (def-dtd-parser-state state-dtd-comment 4)
  58   (def-dtd-parser-state state-dtd-!-token 5)
  59   (def-dtd-parser-state state-dtd-!-element 6)
  60   (def-dtd-parser-state state-dtd-!-element-name 7)
  61   (def-dtd-parser-state state-dtd-!-element-content 8)
  62   (def-dtd-parser-state state-dtd-!-element-type 9)
  63   (def-dtd-parser-state state-dtd-!-element-type-paren 10)
  64   (def-dtd-parser-state state-dtd-!-element-type-token 11)
  65   (def-dtd-parser-state state-dtd-!-element-type-end 12)
  66   (def-dtd-parser-state state-dtd-!-element-type-paren-name 13)
  67   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd 14)
  68   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd2 15)
  69   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd3 16)
  70   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd4 17)
  71   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd5 18)
  72   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd6 19)
  73   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd7 20)
  74   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd8 21)
  75   (def-dtd-parser-state state-dtd-!-element-type-paren-pcd9 22)
  76   (def-dtd-parser-state state-dtd-!-element-type-paren-name2 23)
  77   ;;(def-dtd-parser-state state-dtd-!-element-type-paren-seq 24) folded into choice
  78   (def-dtd-parser-state state-dtd-!-element-type-paren-choice 25)
  79   (def-dtd-parser-state state-dtd-!-element-type-paren2 26)
  80   (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name 27)
  81   (def-dtd-parser-state state-dtd-!-element-type-paren-choice-paren 28)
  82   (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name2 29)
  83   (def-dtd-parser-state state-dtd-!-element-type-paren3 30)
  84   (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name3 31)
  85   (def-dtd-parser-state state-dtd-!-attlist 32)
  86   (def-dtd-parser-state state-dtd-!-attlist-name 33)
  87   (def-dtd-parser-state state-dtd-!-attdef 34)
  88   (def-dtd-parser-state state-dtd-!-attdef-name 35)
  89   (def-dtd-parser-state state-dtd-!-attdef-type 36)
  90   ;;(def-dtd-parser-state state-dtd-!-attdef-enumeration 37)
  91   (def-dtd-parser-state state-dtd-!-attdef-decl 38)
  92   (def-dtd-parser-state state-dtd-!-attdef-decl-type 39)
  93   (def-dtd-parser-state state-dtd-!-attdef-decl-value 40)
  94   (def-dtd-parser-state state-dtd-!-attdef-decl-value2 41)
  95   (def-dtd-parser-state state-dtd-!-attdef-decl-value3 42)
  96   (def-dtd-parser-state state-dtd-!-attdef-decl-value4 43)
  97   (def-dtd-parser-state state-dtd-!-attdef-decl-value5 44)
  98   (def-dtd-parser-state state-dtd-!-attdef-decl-value6 45)
  99   (def-dtd-parser-state state-dtd-!-attdef-decl-value7 46)
 100   (def-dtd-parser-state state-dtd-!-attdef-notation 47)
 101   (def-dtd-parser-state state-dtd-!-attdef-notation2 48)
 102   (def-dtd-parser-state state-dtd-!-attdef-notation3 49)
 103   (def-dtd-parser-state state-dtd-!-attdef-notation4 50)
 104   (def-dtd-parser-state state-dtd-!-attdef-type2 51)
 105   (def-dtd-parser-state state-dtd-!-entity 52)
 106   (def-dtd-parser-state state-dtd-!-entity2 53)
 107   (def-dtd-parser-state state-dtd-!-entity3 54)
 108   (def-dtd-parser-state state-dtd-!-entity4 55)
 109   (def-dtd-parser-state state-dtd-!-entity-value 56)
 110   (def-dtd-parser-state state-dtd-!-entity5 57)
 111   (def-dtd-parser-state state-dtd-!-entity6 58)
 112   (def-dtd-parser-state state-!-dtd-system 59)
 113   (def-dtd-parser-state state-!-dtd-public 60)
 114   (def-dtd-parser-state state-!-dtd-system2 61)
 115   (def-dtd-parser-state state-!-dtd-system3 62)
 116   (def-dtd-parser-state state-!-dtd-system4 63)
 117   (def-dtd-parser-state state-!-dtd-system5 64)
 118   (def-dtd-parser-state state-!-dtd-system6 65)
 119   (def-dtd-parser-state state-!-dtd-system7 66)
 120   (def-dtd-parser-state state-!-dtd-public2 67)
 121   (def-dtd-parser-state state-dtd-!-notation 68)
 122   (def-dtd-parser-state state-dtd-!-notation2 69)
 123   (def-dtd-parser-state state-dtd-!-notation3 70)
 124   (def-dtd-parser-state state-dtd-?-2 71)
 125   (def-dtd-parser-state state-dtd-?-3 72)
 126   (def-dtd-parser-state state-dtd-?-4 73)
 127   (def-dtd-parser-state state-dtd-comment2 74)
 128   (def-dtd-parser-state state-dtd-comment3 75)
 129   (def-dtd-parser-state state-dtd-comment4 76)
 130   (def-dtd-parser-state state-dtd-!-entity7 77)
 131   (def-dtd-parser-state state-dtd-!-attdef-notation5 78)
 132   (def-dtd-parser-state state-!-dtd-public3 79)
 133   (def-dtd-parser-state state-dtd-!-cond 80)
 134   (def-dtd-parser-state state-dtd-!-cond2 81)
 135   (def-dtd-parser-state state-dtd-!-include 82)
 136   (def-dtd-parser-state state-dtd-!-ignore 83)
 137   (def-dtd-parser-state state-dtd-!-include2 84)
 138   (def-dtd-parser-state state-dtd-!-include3 85)
 139   (def-dtd-parser-state state-dtd-!-include4 86)
 140   (def-dtd-parser-state state-dtd-!-ignore2 87)
 141   (def-dtd-parser-state state-dtd-!-ignore3 88)
 142   (def-dtd-parser-state state-dtd-!-ignore4 89)
 143   (def-dtd-parser-state state-dtd-!-ignore5 90)
 144   (def-dtd-parser-state state-dtd-!-ignore6 91)
 145   (def-dtd-parser-state state-dtd-!-ignore7 92)
 146   )
 147
 148 (defun next-dtd-token (tokenbuf
 149                        external include-count external-callback)
 150   (declare (:fbound parse-default-value) (optimize (speed 3) (safety 1)))
 151   (macrolet ((add-to-entity-buf (entity-symbol p-value)
 152                `(progn
 153                   (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
 154                         (iostruct-entity-bufs tokenbuf))))
 155
 156              (un-next-char (ch)
 157                `(push ,ch (iostruct-unget-char tokenbuf)))
 158
 159              (clear-coll (coll)
 160                `(setf (collector-next ,coll) 0))
 161
 162              (add-to-coll (coll ch)
 163                `(let ((.next. (collector-next ,coll)))
 164                   (if* (>= .next. (collector-max ,coll))
 165                      then (grow-and-add ,coll ,ch)
 166                      else (setf (schar (collector-data ,coll) .next.)
 167                             ,ch)
 168                           (setf (collector-next ,coll) (1+ .next.)))))
 169
 170              (to-preferred-case (ch)
 171                ;; should check the case mode
 172                `(char-downcase ,ch))
 173
 174              )
 175     (let ((state state-dtdstart)
 176           (coll  (get-collector))
 177           (entity  (get-collector))
 178           (tag-to-return)
 179           (contents-to-return)
 180           (pending (list nil))
 181           (pending-type)
 182           (value-delim)
 183           (public-string)
 184           (char-code 0)
 185           (check-count 0)
 186           (ignore-count 0)
 187           (reference-save-state)
 188           (prefp)
 189           (entityp)
 190           (pentityp)
 191           (prev-state)
 192           (ch))
 193       (loop
 194         (setq ch (get-next-char tokenbuf))
 195         (when *debug-dtd*
 196           (format t "~@<dtd ~:Ichar: ~s ~:_state: ~s ~:_contents: ~s ~:_pending: ~s ~:_pending-type: ~s ~:_entity-names ~s~:>~%"
 197                   ch (or (cdr (assoc state dtd-parser-states)) state)
 198                   contents-to-return pending pending-type
 199                   (iostruct-entity-names tokenbuf)))
 200         (if* (null ch)
 201            then (setf prev-state state)
 202                 (setf state :eof)
 203                 (return)                ;; eof -- exit loop
 204                 )
 205
 206         (case state
 207           (#.state-dtdstart
 208            (if* (and (eq #\] ch)
 209                      external (> include-count 0)) then
 210                    (setf state state-dtd-!-include3)
 211             elseif (and (eq #\] ch) (not external)) then (return)
 212             elseif (eq #\< ch) then (setf state state-tokenstart)
 213             elseif (xml-space-p ch) then nil
 214             elseif (eq #\% ch) then (external-param-reference tokenbuf coll external-callback)
 215               else (dotimes (i 15)
 216                      (add-to-coll coll ch)
 217                      (setq ch (get-next-char tokenbuf))
 218                      (if* (null ch)
 219                         then (return)))
 220                    (xml-error (concatenate 'string
 221                                 "illegal DTD characters, starting at: '"
 222                                 (compute-coll-string coll)
 223                                 "'"))
 224                    ))
 225           (#.state-dtd-!-include3
 226            (if* (eq #\] ch) then (setf state state-dtd-!-include4)
 227               else
 228                    (dotimes (i 15)
 229                      (add-to-coll coll ch)
 230                      (setq ch (get-next-char tokenbuf))
 231                      (if* (null ch)
 232                         then (return)))
 233                    (xml-error (concatenate 'string
 234                                 "illegal DTD token, starting at: ']"
 235                                 (compute-coll-string coll)
 236                                 "'"))))
 237           (#.state-dtd-!-include4
 238            (if* (eq #\> ch) then (return)
 239                 else
 240                    (dotimes (i 15)
 241                      (add-to-coll coll ch)
 242                      (setq ch (get-next-char tokenbuf))
 243                      (if* (null ch)
 244                         then (return)))
 245                    (xml-error (concatenate 'string
 246                                 "illegal DTD token, starting at: ']]"
 247                                 (compute-coll-string coll)
 248                                 "'"))))
 249           #+ignore
 250           (#.state-dtd-pref
 251            (if* (xml-name-start-char-p ch) then
 252                    (add-to-coll coll ch)
 253                    (setf state state-dtd-pref2)
 254               else (dotimes (i 15)
 255                      (add-to-coll coll ch)
 256                      (setq ch (get-next-char tokenbuf))
 257                      (if* (null ch)
 258                         then (return)))
 259                    (xml-error (concatenate 'string
 260                                 "illegal DTD parameter reference name, starting at: '"
 261                                 (compute-coll-string coll)
 262                                 "'"))
 263                    ))
 264           (#.state-tokenstart
 265            (if* (eq #\? ch) then (setf state state-dtd-?)
 266             elseif (eq #\! ch) then (setf state state-dtd-!)
 267               else (dotimes (i 15)
 268                      (add-to-coll coll ch)
 269                      (setq ch (get-next-char tokenbuf))
 270                      (if* (null ch)
 271                         then (return)))
 272                    (xml-error (concatenate 'string
 273                                 "illegal DTD characters, starting at: '<"
 274                                 (compute-coll-string coll)
 275                                 "'"))
 276                    ))
 277           (#.state-dtd-?
 278            (if* (xml-name-char-p ch)
 279               then
 280                    (add-to-coll coll ch)
 281             elseif (and external (eq #\% ch)) then
 282                    (external-param-reference tokenbuf coll external-callback)
 283               else
 284                    (when (not (xml-space-p ch))
 285                      (xml-error (concatenate 'string
 286                                   "expecting name following: '<?"
 287                                   (compute-coll-string coll)
 288                                   "' ; got: '" (string ch) "'"))
 289                      )
 290                    (when (= (collector-next coll) 0)
 291                      (xml-error "null <? token"))
 292                    (if* (and (= (collector-next coll) 3)
 293                              (or (eq (elt (collector-data coll) 0) #\X)
 294                                  (eq (elt (collector-data coll) 0) #\x))
 295                              (or (eq (elt (collector-data coll) 1) #\M)
 296                                  (eq (elt (collector-data coll) 1) #\m))
 297                              (or (eq (elt (collector-data coll) 2) #\L)
 298                                  (eq (elt (collector-data coll) 2) #\l)))
 299                       then
 300                            (xml-error "<?xml not allowed in dtd")
 301                       else
 302                            (setq tag-to-return (compute-tag coll))
 303                            (setf state state-dtd-?-2))
 304                    (clear-coll coll)))
 305           (#.state-dtd-?-2
 306            (if* (xml-space-p ch)
 307               then nil
 308             elseif (and external (eq #\% ch)) then
 309                    (external-param-reference tokenbuf coll external-callback)
 310             elseif (not (xml-char-p ch))
 311               then (xml-error "XML is not well formed") ;; no test
 312               else (add-to-coll coll ch)
 313                    (setf state state-dtd-?-3)))
 314           (#.state-dtd-?-3
 315            (if* (eq #\? ch)
 316               then (setf state state-dtd-?-4)
 317             elseif (not (xml-char-p ch))
 318               then (xml-error "XML is not well formed") ;; no test
 319               else (add-to-coll coll ch)))
 320           (#.state-dtd-?-4
 321            (if* (eq #\> ch)
 322               then
 323                    (push (compute-coll-string coll) contents-to-return)
 324                    (clear-coll coll)
 325                    (return)
 326               else (setf state state-dtd-?-3)
 327                    (add-to-coll coll #\?)
 328                    (add-to-coll coll ch)))
 329           (#.state-dtd-!
 330            (if* (eq #\- ch) then (setf state state-dtd-comment)
 331             elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-token)
 332                    (un-next-char ch)
 333             elseif (and (eq #\[ ch) external) then
 334                    (setf state state-dtd-!-cond)
 335               else (dotimes (i 15)
 336                      (add-to-coll coll ch)
 337                      (setq ch (get-next-char tokenbuf))
 338                      (if* (null ch)
 339                         then (return)))
 340                    (xml-error (concatenate 'string
 341                                 "illegal DTD characters, starting at: '<!"
 342                                 (compute-coll-string coll)
 343                                 "'"))
 344                    ))
 345           (#.state-dtd-!-cond
 346            (if* (xml-space-p ch) then nil
 347             elseif (and external (eq #\% ch)) then
 348                    (external-param-reference tokenbuf coll external-callback)
 349             elseif (eq #\I ch) then (setf state state-dtd-!-cond2)
 350               else (error "this should not happen")
 351                    ))
 352           (#.state-dtd-!-cond2
 353            (if* (eq #\N ch) then (setf state state-dtd-!-include)
 354                    (setf check-count 2)
 355             elseif (eq #\G ch) then (setf state state-dtd-!-ignore)
 356                    (setf check-count 2)
 357               else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
 358                    ))
 359           (#.state-dtd-!-ignore
 360            (if* (and (eq check-count 5) (eq ch #\E)) then
 361                    (setf state state-dtd-!-ignore2)
 362             elseif (eq ch (elt "IGNORE" check-count)) then
 363                    (incf check-count)
 364               else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
 365                    ))
 366           (#.state-dtd-!-ignore2
 367            (if* (xml-space-p ch) then nil
 368             elseif (and external (eq #\% ch)) then
 369                    (external-param-reference tokenbuf coll external-callback)
 370             elseif (eq #\[ ch) then (setf state state-dtd-!-ignore3)
 371                    (incf ignore-count)
 372               else (xml-error "'[' missing after '<![Ignore'")))
 373           (#.state-dtd-!-ignore3
 374            (if* (eq #\< ch) then (setf state state-dtd-!-ignore4)
 375             elseif (eq #\] ch) then (setf state state-dtd-!-ignore5)))
 376           (#.state-dtd-!-ignore4
 377            (if* (eq #\! ch) then (setf state state-dtd-!-ignore6)
 378               else (un-next-char ch)
 379                    (setf state state-dtd-!-ignore3)))
 380           (#.state-dtd-!-ignore5
 381            (if* (eq #\] ch) then (setf state state-dtd-!-ignore7)
 382               else (un-next-char ch)
 383                    (setf state state-dtd-!-ignore3)))
 384           (#.state-dtd-!-ignore6
 385            (if* (eq #\[ ch) then (incf ignore-count)
 386                    (setf state state-dtd-!-ignore3)
 387               else (un-next-char ch)
 388                    (setf state state-dtd-!-ignore3)))
 389           (#.state-dtd-!-ignore7
 390            (if* (eq #\> ch) then (decf ignore-count)
 391                    (when (= ignore-count 0) (return))
 392               else (un-next-char ch)
 393                    (setf state state-dtd-!-ignore3)))
 394           (#.state-dtd-!-include
 395            (if* (and (eq check-count 6) (eq ch #\E)) then
 396                    (setf state state-dtd-!-include2)
 397             elseif (eq ch (elt "INCLUD" check-count)) then
 398                    (incf check-count)
 399               else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
 400                    ))
 401           (#.state-dtd-!-include2
 402            (if* (xml-space-p ch) then nil
 403             elseif (and external (eq #\% ch)) then
 404                    (external-param-reference tokenbuf coll external-callback)
 405             elseif (eq #\[ ch) then (return)
 406               else (xml-error "'[' missing after '<![INCLUDE'")))
 407           (#.state-dtd-comment
 408            (if* (eq #\- ch)
 409               then (setf state state-dtd-comment2)
 410                    (setf tag-to-return :comment)
 411               else (clear-coll coll)
 412                    (dotimes (i 15)
 413                      (add-to-coll coll ch)
 414                      (setq ch (get-next-char tokenbuf))
 415                      (if* (null ch)
 416                         then (return)))
 417                    (xml-error (concatenate 'string
 418                                 "illegal token following '<![-', starting at '<!-"
 419                                 (compute-coll-string coll)
 420                                 "'"))
 421                    ))
 422           (#.state-dtd-comment2
 423            (if* (eq #\- ch)
 424               then (setf state state-dtd-comment3)
 425               else (add-to-coll coll ch)))
 426           (#.state-dtd-comment3
 427            (if* (eq #\- ch)
 428               then (setf state state-dtd-comment4)
 429               else (setf state state-dtd-comment2)
 430                    (add-to-coll coll #\-) (add-to-coll coll ch)))
 431           (#.state-dtd-comment4
 432            (if* (eq #\> ch)
 433               then (push (compute-coll-string coll) contents-to-return)
 434                    (clear-coll coll)
 435                    (return)
 436               else  (clear-coll coll)
 437                    (dotimes (i 15)
 438                      (add-to-coll coll ch)
 439                      (setq ch (get-next-char tokenbuf))
 440                      (if* (null ch)
 441                         then (return)))
 442                    (xml-error (concatenate 'string
 443                                 "illegal token following '--' comment terminator, starting at '--"
 444                                 (compute-coll-string coll)
 445                                 "'"))
 446                    ))
 447           (#.state-dtd-!-token
 448            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
 449             elseif (and external (eq #\% ch)) then
 450                    (external-param-reference tokenbuf coll external-callback)
 451             elseif (xml-space-p ch) then
 452                    (setf tag-to-return (compute-tag coll))
 453                    (clear-coll coll)
 454                    (if* (eq tag-to-return :ELEMENT) then (setf state state-dtd-!-element)
 455                     elseif (eq tag-to-return :ATTLIST) then
 456                            (setf state state-dtd-!-attlist)
 457                     elseif (eq tag-to-return :ENTITY) then
 458                            (setf entityp t)
 459                            (setf state state-dtd-!-entity)
 460                     elseif (eq tag-to-return :NOTATION) then
 461                            (setf state state-dtd-!-notation)
 462                       else
 463                            (xml-error (concatenate 'string
 464                                         "illegal DTD characters, starting at: '<!"
 465                                         (string tag-to-return)
 466                                         "'")))
 467               else (dotimes (i 15)
 468                      (add-to-coll coll ch)
 469                      (setq ch (get-next-char tokenbuf))
 470                      (if* (null ch)
 471                         then (return)))
 472                    (xml-error (concatenate 'string
 473                                 "illegal DTD characters, starting at: '<!"
 474                                 (compute-coll-string coll)
 475                                 "'"))
 476                    ))
 477           (#.state-dtd-!-notation
 478            (if* (xml-space-p ch) then nil
 479             elseif (and external (eq #\% ch)) then
 480                    (external-param-reference tokenbuf coll external-callback)
 481             elseif (xml-name-start-char-p ch) then
 482                    (add-to-coll coll ch)
 483                    (setf state state-dtd-!-notation2)
 484               else (dotimes (i 15)
 485                      (add-to-coll coll ch)
 486                      (setq ch (get-next-char tokenbuf))
 487                      (if* (null ch)
 488                         then (return)))
 489                    (xml-error (concatenate 'string
 490                                 "illegal DTD characters, starting at: '<!NOTATION "
 491                                 (compute-coll-string coll)
 492                                 "'"))
 493                    ))
 494           (#.state-dtd-!-notation2
 495            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
 496             elseif (and external (eq #\% ch)) then
 497                    (external-param-reference tokenbuf coll external-callback)
 498             elseif (xml-space-p ch) then
 499                    (push (compute-tag coll) contents-to-return)
 500                    (clear-coll coll)
 501                    (setf state state-dtd-!-notation3)
 502               else (dotimes (i 15)
 503                      (add-to-coll coll ch)
 504                      (setq ch (get-next-char tokenbuf))
 505                      (if* (null ch)
 506                         then (return)))
 507                    (xml-error (concatenate 'string
 508                                 "illegal DTD <!NOTATION name: "
 509                                 (compute-coll-string coll)
 510                                 "'"))
 511                    ))
 512           (#.state-dtd-!-notation3
 513            (if* (xml-space-p ch) then nil
 514             elseif (and external (eq #\% ch)) then
 515                    (external-param-reference tokenbuf coll external-callback)
 516             elseif (xml-name-char-p ch) then
 517                    (add-to-coll coll ch)
 518                    (setf state state-dtd-!-entity6)
 519               else (dotimes (i 15)
 520                      (add-to-coll coll ch)
 521                      (setq ch (get-next-char tokenbuf))
 522                      (if* (null ch)
 523                         then (return)))
 524                    (xml-error (concatenate 'string
 525                                 "illegal DTD <!NOTATION spec for "
 526                                 (string (first contents-to-return))
 527                                 ": '"
 528                                 (compute-coll-string coll)
 529                                 "'"))
 530                    ))
 531           (#.state-dtd-!-entity
 532            (if* (eq #\% ch) then (push :param contents-to-return)
 533                    (setf pentityp t)
 534                    (setf state state-dtd-!-entity2)
 535             elseif (xml-name-start-char-p ch) then
 536                    (add-to-coll coll ch)
 537                    (setf pending nil)
 538                    (setf state state-dtd-!-entity3)
 539             elseif (xml-space-p ch) then nil
 540             elseif (and external (eq #\% ch)) then
 541                    (external-param-reference tokenbuf coll external-callback)
 542               else (dotimes (i 15)
 543                      (add-to-coll coll ch)
 544                      (setq ch (get-next-char tokenbuf))
 545                      (if* (null ch)
 546                         then (return)))
 547                    (xml-error (concatenate 'string
 548                                 "illegal DTD characters, starting at: '<!ENTITY "
 549                                 (compute-coll-string coll)
 550                                 "'"))
 551                    ))
 552           (#.state-dtd-!-entity2
 553            (if* (xml-space-p ch) then (setf state state-dtd-!-entity7)
 554             elseif (and external (eq #\% ch)) then
 555                    (external-param-reference tokenbuf coll external-callback)
 556               else (dotimes (i 15)
 557                      (add-to-coll coll ch)
 558                      (setq ch (get-next-char tokenbuf))
 559                      (if* (null ch)
 560                         then (return)))
 561                    (xml-error (concatenate 'string
 562                                 "illegal DTD <!ENTITY spec for "
 563                                 (string (first contents-to-return))
 564                                 ": '"
 565                                 (compute-coll-string coll)
 566                                 "'"))
 567                    ))
 568           (#.state-dtd-!-entity3
 569            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
 570             elseif (and external (eq #\% ch)) then
 571                    (external-param-reference tokenbuf coll external-callback)
 572             elseif (xml-space-p ch) then
 573                    (push (compute-tag coll) contents-to-return)
 574                    (setf contents-to-return
 575                      (nreverse contents-to-return))
 576                    (clear-coll coll)
 577                    (setf state state-dtd-!-entity4)
 578               else (dotimes (i 15)
 579                      (add-to-coll coll ch)
 580                      (setq ch (get-next-char tokenbuf))
 581                      (if* (null ch)
 582                         then (return)))
 583                    (xml-error (concatenate 'string
 584                                 "illegal DTD <!ENTITY name: "
 585                                 (compute-coll-string coll)
 586                                 "'"))
 587                    ))
 588           (#.state-dtd-!-entity4
 589            (if* (xml-space-p ch) then nil
 590             elseif (and external (eq #\% ch)) then
 591                    (external-param-reference tokenbuf coll external-callback)
 592             elseif (or (eq #\' ch) (eq #\" ch)) then
 593                    (setf value-delim ch)
 594                    (setf state state-dtd-!-entity-value)
 595             elseif (xml-name-start-char-p ch) then
 596                    (add-to-coll coll ch)
 597                    (setf state state-dtd-!-entity6)
 598               else (dotimes (i 15)
 599                      (add-to-coll coll ch)
 600                      (setq ch (get-next-char tokenbuf))
 601                      (if* (null ch)
 602                         then (return)))
 603                    (xml-error (concatenate 'string
 604                                 "illegal DTD <!ENTITY spec: '"
 605                                 (compute-coll-string coll)
 606                                 "'"))
 607                    ))
 608           (#.state-dtd-!-entity6
 609            (if* (xml-name-char-p ch) ;; starting char already passed more restrictive test
 610               then
 611                    (add-to-coll coll ch)
 612             elseif (and external (eq #\% ch)) then
 613                    (external-param-reference tokenbuf coll external-callback)
 614               else
 615                    (when (not (xml-space-p ch))
 616                      (dotimes (i 15)
 617                        (add-to-coll coll ch)
 618                        (setq ch (get-next-char tokenbuf))
 619                        (if* (null ch)
 620                           then (return)))
 621                      (xml-error
 622                       (concatenate 'string
 623                         "illegal character in '"
 624                         (compute-coll-string coll)
 625                         "' in <! tag: " (string tag-to-return) " "
 626                         (string (first contents-to-return))
 627                       ))
 628                      )
 629                    (let ((token (compute-tag coll)))
 630                      (push token contents-to-return)
 631                      (clear-coll coll)
 632                      (if* (eq :SYSTEM token) then (setf state state-!-dtd-system)
 633                       elseif (eq :PUBLIC token) then (setf state state-!-dtd-public)
 634                         else (xml-error
 635                               (concatenate 'string
 636                                 "expected 'SYSTEM' or 'PUBLIC' got '"
 637                                 (string (first contents-to-return))
 638                                 "' in <! tag: " (string tag-to-return) " "
 639                                 (string (second contents-to-return))))
 640                              )
 641                      )))
 642           (#.state-dtd-!-entity7
 643            (if* (xml-space-p ch) then nil
 644             elseif (and external (eq #\% ch)) then
 645                    (external-param-reference tokenbuf coll external-callback)
 646             elseif (xml-name-start-char-p ch) then
 647                    (add-to-coll coll ch)
 648                    (setf state state-dtd-!-entity3)
 649               else (dotimes (i 15)
 650                      (add-to-coll coll ch)
 651                      (setq ch (get-next-char tokenbuf))
 652                      (if* (null ch)
 653                         then (return)))
 654                    (xml-error (concatenate 'string
 655                                 "illegal DTD <!ENTITY % name: "
 656                                 (compute-coll-string coll)
 657                                 "'"))
 658                    ))
 659           (#.state-!-dtd-public
 660            (if* (xml-space-p ch) then nil
 661             elseif (and external (eq #\% ch)) then
 662                    (external-param-reference tokenbuf coll external-callback)
 663             elseif (or (eq #\" ch) (eq #\' ch)) then
 664                    (setf state state-!-dtd-public2)
 665                    (setf value-delim ch)
 666               else (xml-error
 667                     (concatenate 'string
 668                       "expected quote or double-quote got: '"
 669                       (string ch)
 670                       "' in <! tag: " (string tag-to-return) " "
 671                       (string (second contents-to-return)) " "
 672                       (string (first contents-to-return))
 673                       ))))
 674           (#.state-!-dtd-public2
 675            (if* (eq value-delim ch) then
 676                    (push (setf public-string
 677                            (normalize-public-value
 678                             (compute-coll-string coll))) contents-to-return)
 679                    (clear-coll coll)
 680                    (setf state state-!-dtd-public3)
 681             elseif (pub-id-char-p ch) then (add-to-coll coll ch)
 682               else (dotimes (i 15)
 683                      (add-to-coll coll ch)
 684                      (setq ch (get-next-char tokenbuf))
 685                      (if* (null ch)
 686                         then (return)))
 687                    (xml-error
 688                     (concatenate 'string
 689                       "illegal character in string: '"
 690                       (compute-coll-string coll) "'"))
 691                    ))
 692           (#.state-!-dtd-public3
 693            (if* (xml-space-p ch) then (setf state state-!-dtd-system)
 694             elseif (and external (eq #\% ch)) then
 695                    (external-param-reference tokenbuf coll external-callback)
 696             elseif (and (not entityp)
 697                         (eq #\> ch)) then
 698                    (setf state state-!-dtd-system)
 699                    (return)
 700               else
 701                    (dotimes (i 15)
 702                      (add-to-coll coll ch)
 703                      (setq ch (get-next-char tokenbuf))
 704                      (if* (null ch)
 705                         then (return)))
 706                    (xml-error
 707                     (concatenate 'string
 708                       "Expected space before: '"
 709                       (compute-coll-string coll) "'"))
 710                    ))
 711           (#.state-!-dtd-system
 712            (if* (xml-space-p ch) then nil
 713             elseif (and external (eq #\% ch)) then
 714                    (external-param-reference tokenbuf coll external-callback)
 715             elseif (or (eq #\" ch) (eq #\' ch)) then
 716                    (setf state state-!-dtd-system2)
 717                    (setf value-delim ch)
 718             elseif (and (not entityp)
 719                         (eq #\> ch)) then (return)
 720               else (xml-error
 721                     (concatenate 'string
 722                       "expected quote or double-quote got: '"
 723                       (string ch)
 724                       "' in <! tag: " (string tag-to-return) " "
 725                       (string (second contents-to-return)) " "
 726                       (string (first contents-to-return))
 727                       ))))
 728           (#.state-!-dtd-system2
 729            (when (not (xml-char-p ch))
 730              (xml-error "XML is not well formed")) ;; not tested
 731            (if* (eq value-delim ch) then
 732                    (let ((entity-symbol (first (last contents-to-return)))
 733                          (system-string (compute-coll-string coll)))
 734                      (if* pentityp then
 735                              (when (not (assoc entity-symbol (iostruct-parameter-entities tokenbuf)))
 736                                (setf (iostruct-parameter-entities tokenbuf)
 737                                  (acons entity-symbol (list (parse-uri system-string)
 738                                                             tag-to-return
 739                                                             public-string)
 740                                         (iostruct-parameter-entities tokenbuf)))
 741                                )
 742                         else
 743                             (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
 744                                (setf (iostruct-general-entities tokenbuf)
 745                                  (acons entity-symbol (list (parse-uri system-string)
 746                                                             tag-to-return
 747                                                             public-string
 748                                                             )
 749                                         (iostruct-general-entities tokenbuf)))
 750                                (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
 751                                (setf (iostruct-general-entities tokenbuf)
 752                                  (acons entity-symbol (list (parse-uri system-string)
 753                                                             tag-to-return
 754                                                             public-string
 755                                                             )
 756                                         (iostruct-general-entities tokenbuf))))
 757                                )
 758                              )
 759                      (push system-string contents-to-return))
 760                    (clear-coll coll)
 761                    (setf state state-!-dtd-system3)
 762               else (add-to-coll coll ch)))
 763           (#.state-!-dtd-system3
 764            (if* (xml-space-p ch) then (setf state state-!-dtd-system4)
 765             elseif (and external (eq #\% ch)) then
 766                    (external-param-reference tokenbuf coll external-callback)
 767             elseif (eq #\> ch) then (return)
 768               else
 769                    (dotimes (i 15)
 770                      (add-to-coll coll ch)
 771                      (setq ch (get-next-char tokenbuf))
 772                      (if* (null ch)
 773                         then (return)))
 774                    (xml-error (concatenate 'string
 775                                 "illegal DTD <!ENTITY value for "
 776                                 (string (first (nreverse contents-to-return)))
 777                                 ": '"
 778                                 (compute-coll-string coll)
 779                                 "'"))
 780                    ))
 781           (#.state-!-dtd-system4
 782            (if* (xml-space-p ch) then nil
 783             elseif (and external (eq #\% ch)) then
 784                    (external-param-reference tokenbuf coll external-callback)
 785             elseif (and (not pentityp) (xml-name-start-char-p ch)) then
 786                    (add-to-coll coll ch)
 787                    (setf state state-!-dtd-system5)
 788             elseif (eq #\> ch) then (return)
 789               else (dotimes (i 15)
 790                      (add-to-coll coll ch)
 791                      (setq ch (get-next-char tokenbuf))
 792                      (if* (null ch)
 793                         then (return)))
 794                    (xml-error (concatenate 'string
 795                                 "illegal DTD <!ENTITY value for "
 796                                 (string (first (nreverse contents-to-return)))
 797                                 ": '"
 798                                 (compute-coll-string coll)
 799                                 "'"))
 800                    ))
 801           (#.state-!-dtd-system5
 802            (if* (xml-name-char-p ch) then
 803                    (add-to-coll coll ch)
 804             elseif (and external (eq #\% ch)) then
 805                    (external-param-reference tokenbuf coll external-callback)
 806             elseif (xml-space-p ch) then
 807                    (let ((token (compute-tag coll)))
 808                      (when (not (eq :NDATA token))
 809                        (dotimes (i 15)
 810                          (add-to-coll coll ch)
 811                          (setq ch (get-next-char tokenbuf))
 812                          (if* (null ch)
 813                             then (return)))
 814                        (xml-error (concatenate 'string
 815                                     "illegal DTD <!ENTITY value for "
 816                                     (string (first (nreverse contents-to-return)))
 817                                     ": '"
 818                                     (compute-coll-string coll)
 819                                     "'"))
 820                        )
 821                      (clear-coll coll)
 822                      (push token contents-to-return)
 823                      (setf state state-!-dtd-system6))
 824               else (dotimes (i 15)
 825                      (add-to-coll coll ch)
 826                      (setq ch (get-next-char tokenbuf))
 827                      (if* (null ch)
 828                         then (return)))
 829                    (xml-error (concatenate 'string
 830                                 "illegal DTD <!ENTITY value for "
 831                                 (string (first (nreverse contents-to-return)))
 832                                 ": '"
 833                                 (compute-coll-string coll)
 834                                 "'"))
 835                    ))
 836           (#.state-!-dtd-system6
 837            (if* (xml-space-p ch) then nil
 838             elseif (and external (eq #\% ch)) then
 839                    (external-param-reference tokenbuf coll external-callback)
 840             elseif (xml-name-start-char-p ch) then
 841                    (add-to-coll coll ch)
 842                    (setf state state-!-dtd-system7)
 843               else (dotimes (i 15)
 844                      (add-to-coll coll ch)
 845                      (setq ch (get-next-char tokenbuf))
 846                      (if* (null ch)
 847                         then (return)))
 848                    (xml-error (concatenate 'string
 849                                 "illegal DTD <!ENTITY value for "
 850                                 (string (first (nreverse contents-to-return)))
 851                                 ": '"
 852                                 (compute-coll-string coll)
 853                                 "'"))
 854                    ))
 855           (#.state-!-dtd-system7
 856            (if* (xml-name-char-p ch) then
 857                    (add-to-coll coll ch)
 858             elseif (and external (eq #\% ch)) then
 859                    (external-param-reference tokenbuf coll external-callback)
 860             elseif (xml-space-p ch) then
 861                    (push (compute-tag coll) contents-to-return)
 862                    (clear-coll coll)
 863                    (setf state state-dtd-!-entity5) ;; just looking for space, >
 864             elseif (eq #\> ch) then
 865                    (push (compute-tag coll) contents-to-return)
 866                    (clear-coll coll)
 867                    (return)
 868               else (dotimes (i 15)
 869                      (add-to-coll coll ch)
 870                      (setq ch (get-next-char tokenbuf))
 871                      (if* (null ch)
 872                         then (return)))
 873                    (xml-error (concatenate 'string
 874                                 "illegal DTD <!ENTITY value for "
 875                                 (string (first (nreverse contents-to-return)))
 876                                 ": '"
 877                                 (compute-coll-string coll)
 878                                 "'"))
 879                    ))
 880           (#.state-dtd-!-entity-value
 881            (if* (eq ch value-delim) then
 882                    (let ((tmp (compute-coll-string coll)))
 883                      (when (> (length tmp) 0)
 884                        (when (null (first pending)) (setf pending (rest pending)))
 885                        (push tmp pending)))
 886                    (if* (> (length pending) 1) then
 887                            (push (nreverse pending) contents-to-return)
 888                       else (push (first pending) contents-to-return))
 889                    (setf pending (list nil))
 890                    (setf state state-dtd-!-entity5)
 891                    (clear-coll coll)
 892                    (if* pentityp then
 893                            (when (not (assoc (third contents-to-return)
 894                                              (iostruct-parameter-entities tokenbuf)))
 895                              (setf (iostruct-parameter-entities tokenbuf)
 896                                (acons (third contents-to-return)
 897                                       (first contents-to-return)
 898                                       (iostruct-parameter-entities tokenbuf))))
 899                       else
 900                            (when (not (assoc (second contents-to-return)
 901                                              (iostruct-general-entities tokenbuf)))
 902                              (setf (iostruct-general-entities tokenbuf)
 903                                (acons (second contents-to-return)
 904                                       (first contents-to-return)
 905                                       (iostruct-general-entities tokenbuf)))))
 906             elseif (eq #\& ch) then
 907                    (setf reference-save-state state-dtd-!-entity-value)
 908                    (setf state state-dtd-!-attdef-decl-value3)
 909             elseif (eq #\% ch) then
 910                    (setf prefp t)
 911                    (setf reference-save-state state-dtd-!-entity-value)
 912                    (setf state state-dtd-!-attdef-decl-value3)
 913             elseif (xml-char-p ch)
 914               then (add-to-coll coll ch)
 915               else (dotimes (i 15)
 916                      (add-to-coll coll ch)
 917                      (setq ch (get-next-char tokenbuf))
 918                      (if* (null ch)
 919                         then (return)))
 920                    (xml-error (concatenate 'string
 921                                 "illegal DTD <!ENTITY value for "
 922                                 (string (first contents-to-return))
 923                                 ": '"
 924                                 (compute-coll-string coll)
 925                                 "'"))
 926                    ))
 927           (#.state-dtd-!-entity5
 928            (if* (xml-space-p ch) then nil
 929             elseif (and external (eq #\% ch)) then
 930                    (external-param-reference tokenbuf coll external-callback)
 931             elseif (eq #\> ch) then (return)
 932               else (clear-coll coll)
 933                    (dotimes (i 15)
 934                      (add-to-coll coll ch)
 935                      (setq ch (get-next-char tokenbuf))
 936                      (if* (null ch)
 937                         then (return)))
 938                    (xml-error (concatenate 'string
 939                                 "illegal DTD contents following <!ENTITY spec for "
 940                                 (string (first contents-to-return))
 941                                 ": '"
 942                                 (compute-coll-string coll)
 943                                 "'"))
 944                    ))
 945           (#.state-dtd-!-attlist
 946            (if* (xml-name-start-char-p ch) then (setf state state-dtd-!-attlist-name)
 947                    (un-next-char ch)
 948             elseif (xml-space-p ch) then nil
 949             elseif (and external (eq #\% ch)) then
 950                    (external-param-reference tokenbuf coll external-callback)
 951               else (dotimes (i 15)
 952                      (add-to-coll coll ch)
 953                      (setq ch (get-next-char tokenbuf))
 954                      (if* (null ch)
 955                         then (return)))
 956                    (xml-error (concatenate 'string
 957                                 "illegal DTD characters, starting at: '<!ATTLIST "
 958                                 (compute-coll-string coll)
 959                                 "'"))))
 960           (#.state-dtd-!-attlist-name
 961            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
 962             elseif (and external (eq #\% ch)) then
 963                    (external-param-reference tokenbuf coll external-callback)
 964             elseif (xml-space-p ch) then
 965                    (push (compute-tag coll *package*)
 966                          contents-to-return)
 967                    (clear-coll coll)
 968                    (setf state state-dtd-!-attdef)
 969             elseif (eq #\> ch) then
 970                    (push (compute-tag coll *package*)
 971                          contents-to-return)
 972                    (clear-coll coll)
 973                    (return)
 974               else (push (compute-tag coll)
 975                          contents-to-return)
 976                    (clear-coll coll)
 977                    (dotimes (i 15)
 978                      (add-to-coll coll ch)
 979                      (setq ch (get-next-char tokenbuf))
 980                      (if* (null ch)
 981                         then (return)))
 982                    (xml-error (concatenate 'string
 983                                 "illegal DTD <!ATTLIST content spec for "
 984                                 (string (first contents-to-return))
 985                                 ": '"
 986                                 (compute-coll-string coll)
 987                                 "'"))
 988                    ))
 989           (#.state-dtd-!-attdef
 990            (if* (xml-space-p ch) then nil
 991             elseif (and external (eq #\% ch)) then
 992                    (external-param-reference tokenbuf coll external-callback)
 993             elseif (xml-name-start-char-p ch) then
 994                    (un-next-char ch)
 995                    (setf state state-dtd-!-attdef-name)
 996             elseif (eq #\> ch) then (return)
 997               else (dotimes (i 15)
 998                      (add-to-coll coll ch)
 999                      (setq ch (get-next-char tokenbuf))
1000                      (if* (null ch)
1001                         then (return)))
1002                    (xml-error (concatenate 'string
1003                                 "illegal DTD <!ATTLIST content spec for "
1004                                 (string (first contents-to-return))
1005                                 ": '"
1006                                 (compute-coll-string coll)
1007                                 "'"))
1008                    ))
1009           (#.state-dtd-!-attdef-name
1010            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1011             elseif (and external (eq #\% ch)) then
1012                    (external-param-reference tokenbuf coll external-callback)
1013             elseif (xml-space-p ch) then
1014                    (setf (first pending) (compute-tag coll *package*))
1015                    (clear-coll coll)
1016                    (setf state state-dtd-!-attdef-type)
1017               else (dotimes (i 15)
1018                      (add-to-coll coll ch)
1019                      (setq ch (get-next-char tokenbuf))
1020                      (if* (null ch)
1021                         then (return)))
1022                    (xml-error (concatenate 'string
1023                                 "illegal DTD <!ATTLIST type spec for "
1024                                 (string (first contents-to-return))
1025                                 ": '"
1026                                 (compute-coll-string coll)
1027                                 "'"))
1028                    ))
1029           (#.state-dtd-!-attdef-type
1030            (if* (xml-space-p ch) then nil
1031             elseif (and external (eq #\% ch)) then
1032                    (external-param-reference tokenbuf coll external-callback)
1033               else (un-next-char ch)
1034                    ;; let next state do all other checking
1035                    (setf state state-dtd-!-attdef-type2)))
1036           (#.state-dtd-!-attdef-type2
1037            ;; can only be one of a few tokens, but wait until token built to check
1038            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1039             elseif (and (eq #\( ch) (= 0 (length (compute-coll-string coll)))) then
1040                    (push (list :enumeration) pending)
1041                    (setf state state-dtd-!-attdef-notation2)
1042             elseif (and external (eq #\% ch)) then
1043                    (external-param-reference tokenbuf coll external-callback)
1044             elseif (xml-space-p ch) then
1045                    (let ((token (compute-tag coll)))
1046                      (when (and (not (eq :CDATA token))
1047                                 (not (eq :ID token))
1048                                 (not (eq :IDREF token))
1049                                 (not (eq :IDREFS token))
1050                                 (not (eq :ENTITY token))
1051                                 (not (eq :ENTITIES token))
1052                                 (not (eq :NMTOKEN token))
1053                                 (not (eq :NMTOKENS token))
1054                                 (not (eq :NOTATION token)))
1055                        (dotimes (i 15)
1056                          (add-to-coll coll ch)
1057                          (setq ch (get-next-char tokenbuf))
1058                          (if* (null ch)
1059                             then (return)))
1060                        (xml-error (concatenate 'string
1061                                     "illegal DTD <!ATTLIST type spec for "
1062                                     (string (first contents-to-return))
1063                                     ": '"
1064                                     (compute-coll-string coll)
1065                                     "'")))
1066                      (if* (eq token :NOTATION) then
1067                              (push (list token) pending)
1068                              (setf state state-dtd-!-attdef-notation)
1069                         else
1070                              (push token pending)
1071                              (setf state state-dtd-!-attdef-decl))
1072                      )
1073                    (clear-coll coll)
1074               else (dotimes (i 15)
1075                      (add-to-coll coll ch)
1076                      (setq ch (get-next-char tokenbuf))
1077                      (if* (null ch)
1078                         then (return)))
1079                    (xml-error (concatenate 'string
1080                                 "illegal DTD <!ATTLIST type spec for "
1081                                 (string (first contents-to-return))
1082                                 ": '"
1083                                 (compute-coll-string coll)
1084                                 "'"))
1085                    ))
1086           (#.state-dtd-!-attdef-notation
1087            (if* (xml-space-p ch) then nil
1088             elseif (and external (eq #\% ch)) then
1089                    (external-param-reference tokenbuf coll external-callback)
1090             elseif (eq #\( ch) then (setf state state-dtd-!-attdef-notation2)
1091               else (dotimes (i 15)
1092                      (add-to-coll coll ch)
1093                      (setq ch (get-next-char tokenbuf))
1094                      (if* (null ch)
1095                         then (return)))
1096                    (xml-error (concatenate 'string
1097                                 "illegal DTD <!ATTLIST type spec for "
1098                                 (string (first contents-to-return))
1099                                 ": '"
1100                                 (compute-coll-string coll)
1101                                 "'"))
1102                    ))
1103           (#.state-dtd-!-attdef-notation2
1104            (if* (xml-space-p ch) then nil
1105             elseif (and external (eq #\% ch)) then
1106                    (external-param-reference tokenbuf coll external-callback)
1107             elseif (xml-name-start-char-p ch) then
1108                    (setf state state-dtd-!-attdef-notation3)
1109                    (add-to-coll coll ch)
1110             elseif (and (xml-name-char-p ch) (listp (first pending))
1111                         (eq :enumeration (first (reverse (first pending))))) then
1112                    (setf state state-dtd-!-attdef-notation3)
1113                    (add-to-coll coll ch)
1114               else (dotimes (i 15)
1115                      (add-to-coll coll ch)
1116                      (setq ch (get-next-char tokenbuf))
1117                      (if* (null ch)
1118                         then (return)))
1119                    (xml-error (concatenate 'string
1120                                 "illegal DTD <!ATTLIST type spec for "
1121                                 (string (first contents-to-return))
1122                                 ": '"
1123                                 (compute-coll-string coll)
1124                                 "'"))
1125                    ))
1126           (#.state-dtd-!-attdef-notation3
1127            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1128             elseif (and external (eq #\% ch)) then
1129                    (external-param-reference tokenbuf coll external-callback)
1130             elseif (and external (eq #\% ch)) then
1131                    (external-param-reference tokenbuf coll external-callback)
1132             elseif (xml-space-p ch) then
1133                    (push (compute-tag coll) (first pending))
1134                    (clear-coll coll)
1135                    (setf state state-dtd-!-attdef-notation4)
1136             elseif (eq #\| ch) then
1137                    (push (compute-tag coll) (first pending))
1138                    (clear-coll coll)
1139                    (setf state state-dtd-!-attdef-notation2)
1140             elseif (eq #\) ch) then
1141                    (push (compute-tag coll) (first pending))
1142                    (clear-coll coll)
1143                    (setf (first pending) (nreverse (first pending)))
1144                    ;;(setf state state-dtd-!-attdef-decl)
1145                    (setf state state-dtd-!-attdef-notation5)
1146               else (dotimes (i 15)
1147                      (add-to-coll coll ch)
1148                      (setq ch (get-next-char tokenbuf))
1149                      (if* (null ch)
1150                         then (return)))
1151                    (xml-error (concatenate 'string
1152                                 "illegal DTD <!ATTLIST type spec for "
1153                                 (string (first contents-to-return))
1154                                 ": '"
1155                                 (compute-coll-string coll)
1156                                 "'"))
1157                    ))
1158           (#.state-dtd-!-attdef-notation5
1159            (if* (xml-space-p ch) then (setf state state-dtd-!-attdef-decl)
1160             elseif (and external (eq #\% ch)) then
1161                    (external-param-reference tokenbuf coll external-callback)
1162               else
1163                    (dotimes (i 15)
1164                      (add-to-coll coll ch)
1165                      (setq ch (get-next-char tokenbuf))
1166                      (if* (null ch)
1167                         then (return)))
1168                    (xml-error
1169                     (concatenate 'string
1170                       "Expected space before: '"
1171                       (compute-coll-string coll) "'"))))
1172           (#.state-dtd-!-attdef-notation4
1173            (if* (xml-space-p ch) then nil
1174             elseif (and external (eq #\% ch)) then
1175                    (external-param-reference tokenbuf coll external-callback)
1176             elseif (xml-name-char-p ch) then (add-to-coll coll ch)
1177                    (setf state state-dtd-!-attdef-notation3)
1178             elseif (eq #\| ch) then (setf state state-dtd-!-attdef-notation2)
1179             elseif (eq #\) ch) then (setf state state-dtd-!-attdef-decl)
1180                    (setf (first pending) (nreverse (first pending)))
1181               else (dotimes (i 15)
1182                      (add-to-coll coll ch)
1183                      (setq ch (get-next-char tokenbuf))
1184                      (if* (null ch)
1185                         then (return)))
1186                    (xml-error (concatenate 'string
1187                                 "illegal DTD <!ATTLIST type spec for "
1188                                 (string (first contents-to-return))
1189                                 ": '"
1190                                 (compute-coll-string coll)
1191                                 "'"))
1192                    ))
1193           (#.state-dtd-!-attdef-decl
1194            (if* (eq #\# ch) then
1195                    (setf state state-dtd-!-attdef-decl-type)
1196             elseif (or (eq #\' ch) (eq #\" ch)) then
1197                    (setf value-delim ch)
1198                    (setf state state-dtd-!-attdef-decl-value)
1199             elseif (xml-space-p ch) then nil
1200             elseif (and external (eq #\% ch)) then
1201                    (external-param-reference tokenbuf coll external-callback)
1202               else (dotimes (i 15)
1203                      (add-to-coll coll ch)
1204                      (setq ch (get-next-char tokenbuf))
1205                      (if* (null ch)
1206                         then (return)))
1207                    (xml-error (concatenate 'string
1208                                 "illegal DTD <!ATTLIST type spec for "
1209                                 (string (first contents-to-return))
1210                                 ": '"
1211                                 (compute-coll-string coll)
1212                                 "'"))
1213                    ))
1214           (#.state-dtd-!-attdef-decl-value
1215            (if* (eq ch value-delim) then
1216                    #-ignore
1217                    (push (first (parse-default-value (list (compute-coll-string coll))
1218                                               tokenbuf external-callback))
1219                          pending)
1220                    #+ignore
1221                    (push (compute-coll-string coll) pending)
1222                    (setf contents-to-return
1223                      (append contents-to-return
1224                              (if* entityp then
1225                                     (nreverse pending)
1226                                 else (list (nreverse pending)))))
1227                    (setf pending (list nil))
1228                    (setf state state-dtd-!-attdef)
1229                    (clear-coll coll)
1230             elseif (eq #\& ch) then (setf state state-dtd-!-attdef-decl-value3)
1231                    (setf reference-save-state state-dtd-!-attdef-decl-value)
1232             elseif (and (xml-char-p ch) (not (eq #\< ch)))
1233               then (add-to-coll coll ch)
1234               else (dotimes (i 15)
1235                      (add-to-coll coll ch)
1236                      (setq ch (get-next-char tokenbuf))
1237                      (if* (null ch)
1238                         then (return)))
1239                    (xml-error (concatenate 'string
1240                                 "illegal DTD <!ATTLIST type spec for "
1241                                 (string (first contents-to-return))
1242                                 ": '"
1243                                 (compute-coll-string coll)
1244                                 "'"))
1245                    ))
1246           (#.state-dtd-!-attdef-decl-value3
1247            (if* (and (not prefp) (eq #\# ch))
1248               then (setf state state-dtd-!-attdef-decl-value4)
1249             elseif (xml-name-start-char-p ch)
1250               then (setf state state-dtd-!-attdef-decl-value5)
1251                    (when (not prefp) (add-to-coll coll #\&))
1252                    (un-next-char ch)
1253               else (clear-coll coll)
1254                    (dotimes (i 15)
1255                      (add-to-coll coll ch)
1256                      (setq ch (get-next-char tokenbuf))
1257                      (if* (null ch)
1258                         then (return)))
1259                    (xml-error (concatenate 'string
1260                                 "illegal reference name, starting at: '&"
1261                                 (compute-coll-string coll)
1262                                 "'"))))
1263           (#.state-dtd-!-attdef-decl-value4
1264            (if* (eq #\x ch)
1265               then (setf state state-dtd-!-attdef-decl-value6)
1266             elseif (<= (char-code #\0) (char-code ch) (char-code #\9))
1267               then (setf state state-dtd-!-attdef-decl-value7)
1268                    (un-next-char ch)
1269               else (clear-coll coll)
1270                    (dotimes (i 15)
1271                      (add-to-coll coll ch)
1272                      (setq ch (get-next-char tokenbuf))
1273                      (if* (null ch)
1274                         then (return)))
1275                    (xml-error (concatenate 'string
1276                                 "illegal character reference code, starting at: '&#"
1277                                 (compute-coll-string coll)
1278                                 "'"))
1279                    ))
1280           (#.state-dtd-!-attdef-decl-value5
1281            (if* (xml-name-char-p ch)
1282               then (add-to-coll entity ch)
1283                    (when (not prefp) (add-to-coll coll ch))
1284             elseif (eq #\; ch)
1285               then
1286                    (if* (not prefp) then (add-to-coll coll ch)
1287                     elseif (not external) then
1288                            (xml-error
1289                             (concatenate 'string
1290                               "internal dtd subset cannot reference parameter entity within a token; entity: "
1291                               (compute-coll-string entity)))
1292                       else
1293                            (let* ((entity-symbol (compute-tag entity))
1294                                   (p-value
1295                                    (assoc entity-symbol (iostruct-parameter-entities tokenbuf))))
1296                              (clear-coll entity)
1297                              (if* (and (iostruct-do-entity tokenbuf)
1298                                        (setf p-value
1299                                          (assoc entity-symbol
1300                                                 (iostruct-parameter-entities tokenbuf)))) then
1301                                      (setf p-value (rest p-value))
1302                                      (when (member entity-symbol (iostruct-entity-names tokenbuf))
1303                                          (xml-error (concatenate 'string
1304                                                       "entity:"
1305                                                       (string entity-symbol)
1306                                                       " in recursive reference")))
1307                                      (push entity-symbol (iostruct-entity-names tokenbuf))
1308                                      (if* (stringp p-value) then
1309                                              (dotimes (i (length p-value))
1310                                                (add-to-coll coll (schar p-value i)))
1311                                       elseif p-value then
1312                                              (if* (null external-callback) then
1313                                                      (setf (iostruct-do-entity tokenbuf) nil)
1314                                                 else
1315                                                      (let ((count 0) (string "<?xml ") last-ch
1316                                                            save-ch save-unget
1317                                                            (tmp-count 0)
1318                                                            (entity-stream
1319                                                             (apply external-callback p-value)))
1320                                                        (when entity-stream
1321                                                          (let ((tmp-buf (get-tokenbuf)))
1322                                                            (setf (tokenbuf-stream tmp-buf)
1323                                                              entity-stream)
1324                                                            (setf save-unget
1325                                                              (iostruct-unget-char tokenbuf))
1326                                                            (setf (iostruct-unget-char tokenbuf) nil)
1327                                                            (unicode-check entity-stream tokenbuf)
1328                                                            (when (iostruct-unget-char tokenbuf)
1329                                                              (setf save-ch (first (iostruct-unget-char tokenbuf))))
1330                                                            (setf (iostruct-unget-char tokenbuf) save-unget)
1331                                                            (loop
1332                                                              (let ((cch
1333                                                                     (if* save-ch
1334                                                                        then
1335                                                                             (let ((s2 save-ch))
1336                                                                               (setf save-ch nil)
1337                                                                               s2)
1338                                                                        else
1339                                                                             (next-char
1340                                                                              tmp-buf
1341                                                                              (iostruct-read-sequence-func
1342                                                                               tokenbuf)))))
1343                                                                (when (null cch) (return))
1344                                                                (when *debug-dtd*
1345                                                                  (format t "dtd-char: ~s~%" cch))
1346                                                                (if* (< count 0) then
1347                                                                        (if* (and (eq last-ch #\?)
1348                                                                                  (eq cch #\>)) then
1349                                                                                (setf count 6)
1350                                                                           else (setf last-ch cch))
1351                                                                 elseif (< count 6) then
1352                                                                        (when (and (= count 5)
1353                                                                                (xml-space-p cch))
1354                                                                          (setf cch #\space))
1355                                                                        (if* (not (eq cch
1356                                                                                     (schar string count)
1357                                                                                     )) then
1358                                                                                (loop
1359                                                                                  (when (= tmp-count count)
1360                                                                                    (return))
1361                                                                                  (add-to-coll coll
1362                                                                                               (schar string
1363                                                                                                      tmp-count))
1364                                                                                  (incf tmp-count))
1365                                                                                (add-to-coll coll cch)
1366                                                                                (setf count 10)
1367                                                                           else (incf count))
1368                                                                 elseif (= count 6) then
1369                                                                        (dotimes (i 6)
1370                                                                          (add-to-coll coll (schar string i)))
1371                                                                        (setf count 10)
1372                                                                   else (add-to-coll coll cch))))
1373                                                            (setf (iostruct-entity-names tokenbuf)
1374                                                              (rest (iostruct-entity-names tokenbuf)))
1375                                                            (close entity-stream)
1376                                                            (put-back-tokenbuf tmp-buf)))))
1377                                              )
1378                                      (setf state state-dtdstart)
1379                                 else nil
1380                                      )))
1381                    (setf state reference-save-state)
1382               else (let ((tmp (compute-coll-string entity)))
1383                      (clear-coll coll)
1384                      (dotimes (i 15)
1385                        (add-to-coll coll ch)
1386                        (setq ch (get-next-char tokenbuf))
1387                        (if* (null ch)
1388                           then (return)))
1389                      (xml-error (concatenate 'string
1390                                   "reference not terminated by ';', starting at: '&"
1391                                   tmp
1392                                   (compute-coll-string coll)
1393                                   "'")))
1394                    ))
1395           (#.state-dtd-!-attdef-decl-value6
1396            (let ((code (char-code ch)))
1397              (if* (eq #\; ch)
1398                 then (add-to-coll coll (code-char char-code))
1399                      (setf char-code 0)
1400                      (setq state state-dtd-!-attdef-decl-value)
1401               elseif (<= (char-code #\0) code (char-code #\9))
1402                 then (setf char-code (+ (* char-code 16) (- code (char-code #\0))))
1403               elseif (<= (char-code #\A) code (char-code #\F))
1404                 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\A))))
1405               elseif (<= (char-code #\a) code (char-code #\f))
1406                 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\a))))
1407                 else (clear-coll coll)
1408                      (dotimes (i 15)
1409                        (add-to-coll coll ch)
1410                        (setq ch (get-next-char tokenbuf))
1411                        (if* (null ch)
1412                           then (return)))
1413                      (xml-error (concatenate 'string
1414                                   "illegal hexidecimal character reference code, starting at: '"
1415                                   (compute-coll-string coll)
1416                                   "', calculated char code: "
1417                                   (format nil "~s" char-code)))
1418                      )))
1419           (#.state-dtd-!-attdef-decl-value7
1420            (let ((code (char-code ch)))
1421              (if* (eq #\; ch)
1422                 then (add-to-coll coll (code-char char-code))
1423                      (setf char-code 0)
1424                      (setq state reference-save-state)
1425               elseif (<= (char-code #\0) code (char-code #\9))
1426                 then (setf char-code (+ (* char-code 10) (- code (char-code #\0))))
1427                 else (clear-coll coll)
1428                      (dotimes (i 15)
1429                        (add-to-coll coll ch)
1430                        (setq ch (get-next-char tokenbuf))
1431                        (if* (null ch)
1432                           then (return)))
1433                      (xml-error (concatenate 'string
1434                                   "illegal decimal character reference code, starting at: '"
1435                                   (compute-coll-string coll)
1436                                   "', calculated char code: "
1437                                   (format nil "~s" char-code)))
1438                      )))
1439           (#.state-dtd-!-attdef-decl-type
1440            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1441             elseif (and external (eq #\% ch)) then
1442                    (external-param-reference tokenbuf coll external-callback)
1443             elseif (or (xml-space-p ch) (eq #\> ch)) then
1444                    (let ((token (compute-tag coll)))
1445                      (when (and (not (eq :REQUIRED token))
1446                                 (not (eq :IMPLIED token))
1447                                 (not (eq :FIXED token)))
1448                        (dotimes (i 15)
1449                          (add-to-coll coll ch)
1450                          (setq ch (get-next-char tokenbuf))
1451                          (if* (null ch)
1452                             then (return)))
1453                        (xml-error (concatenate 'string
1454                                     "illegal DTD <!ATTLIST type spec for "
1455                                     (string (first contents-to-return))
1456                                     ": '"
1457                                     (compute-coll-string coll)
1458                                     "'")))
1459                      (push token pending)
1460                      (if* (eq :FIXED token) then
1461                              (when (eq #\> ch)
1462                                (dotimes (i 15)
1463                                  (add-to-coll coll ch)
1464                                  (setq ch (get-next-char tokenbuf))
1465                                  (if* (null ch)
1466                                     then (return)))
1467                                (xml-error (concatenate 'string
1468                                             "illegal DTD <!ATTLIST type spec for "
1469                                             (string (first contents-to-return))
1470                                             ": '"
1471                                             (compute-coll-string coll)
1472                                             "'")))
1473                              (setf state state-dtd-!-attdef-decl-value2)
1474                       elseif (eq #\> ch) then
1475                              (setf contents-to-return
1476                                (append contents-to-return (list (nreverse pending))))
1477                              (return)
1478                         else (setf contents-to-return
1479                                (append contents-to-return (list (nreverse pending))))
1480                              (setf pending (list nil))
1481                              (setf state state-dtd-!-attdef)))
1482                    (clear-coll coll)
1483               else (dotimes (i 15)
1484                      (add-to-coll coll ch)
1485                      (setq ch (get-next-char tokenbuf))
1486                      (if* (null ch)
1487                         then (return)))
1488                    (xml-error (concatenate 'string
1489                                 "illegal DTD <!ATTLIST type spec for "
1490                                 (string (first contents-to-return))
1491                                 ": '"
1492                                 (compute-coll-string coll)
1493                                 "'"))
1494                    ))
1495           (#. state-dtd-!-attdef-decl-value2
1496               (if* (xml-space-p ch) then nil
1497                elseif (and external (eq #\% ch)) then
1498                    (external-param-reference tokenbuf coll external-callback)
1499                elseif (or (eq #\' ch) (eq #\" ch)) then
1500                       (setf value-delim ch)
1501                       (setf state state-dtd-!-attdef-decl-value)
1502                  else (dotimes (i 15)
1503                      (add-to-coll coll ch)
1504                      (setq ch (get-next-char tokenbuf))
1505                      (if* (null ch)
1506                         then (return)))
1507                    (xml-error (concatenate 'string
1508                                 "illegal DTD <!ATTLIST type spec for "
1509                                 (string (first contents-to-return))
1510                                 ": '"
1511                                 (compute-coll-string coll)
1512                                 "'"))
1513                       ))
1514           (#.state-dtd-!-element
1515            (if* (xml-space-p ch) then nil
1516             elseif (and external (eq #\% ch)) then
1517                    (external-param-reference tokenbuf coll external-callback)
1518             elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-element-name)
1519                    (un-next-char ch)
1520               else (dotimes (i 15)
1521                      (add-to-coll coll ch)
1522                      (setq ch (get-next-char tokenbuf))
1523                      (if* (null ch)
1524                         then (return)))
1525                    (xml-error (concatenate 'string
1526                                 "illegal DTD characters, starting at: '<!ELEMENT "
1527                                 (compute-coll-string coll)
1528                                 "'"))))
1529           (#.state-dtd-!-element-name
1530            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1531             elseif (and external (eq #\% ch)) then
1532                    (external-param-reference tokenbuf coll external-callback)
1533             elseif (xml-space-p ch) then
1534                    (push (compute-tag coll)
1535                          contents-to-return)
1536                    (clear-coll coll)
1537                    (setf state state-dtd-!-element-type)
1538               else (dotimes (i 15)
1539                      (add-to-coll coll ch)
1540                      (setq ch (get-next-char tokenbuf))
1541                      (if* (null ch)
1542                         then (return)))
1543                    (xml-error (concatenate 'string
1544                                 "illegal DTD <!ELEMENT name: '"
1545                                 (compute-coll-string coll)
1546                                 "'"))
1547                    ))
1548           (#.state-dtd-!-element-type
1549            (if* (eq #\( ch) then (setf state state-dtd-!-element-type-paren)
1550             elseif (xml-space-p ch) then nil
1551             elseif (and external (eq #\% ch)) then
1552                    (external-param-reference tokenbuf coll external-callback)
1553             elseif (xml-name-start-char-p ch) then
1554                    (un-next-char ch)
1555                    (setf state state-dtd-!-element-type-token)
1556               else (dotimes (i 15)
1557                      (add-to-coll coll ch)
1558                      (setq ch (get-next-char tokenbuf))
1559                      (if* (null ch)
1560                         then (return)))
1561                    (xml-error (concatenate 'string
1562                                 "illegal DTD <!ELEMENT content spec for "
1563                                 (string (first contents-to-return))
1564                                 ": '"
1565                                 (compute-coll-string coll)
1566                                 "'"))
1567                    ))
1568           (#.state-dtd-!-element-type-paren
1569            (if* (xml-space-p ch) then nil
1570             elseif (and external (eq #\% ch)) then
1571                    (external-param-reference tokenbuf coll external-callback)
1572             elseif (xml-name-start-char-p ch) then
1573                    (un-next-char ch)
1574                    (setf state state-dtd-!-element-type-paren-name)
1575             elseif (eq #\# ch) then
1576                    (setf state state-dtd-!-element-type-paren-pcd)
1577             elseif (eq #\( ch) then
1578                    (push nil pending)
1579                    (setf state state-dtd-!-element-type-paren-choice-paren)
1580               else (dotimes (i 15)
1581                      (add-to-coll coll ch)
1582                      (setq ch (get-next-char tokenbuf))
1583                      (if* (null ch)
1584                         then (return)))
1585                    (xml-error (concatenate 'string
1586                                 "illegal DTD <!ELEMENT content spec for "
1587                                 (string (first contents-to-return))
1588                                 ": '"
1589                                 (compute-coll-string coll)
1590                                 "'"))))
1591           (#.state-dtd-!-element-type-paren2
1592            (if* (eq #\> ch) then
1593                    ;; there only one name...
1594                    (setf (first contents-to-return) (first (first contents-to-return)))
1595                    (return)
1596             elseif (eq #\* ch) then
1597                    (setf state state-dtd-!-element-type-paren-pcd5)
1598                    (setf (first contents-to-return) (nreverse (first contents-to-return)))
1599                    (if* (> (length (first contents-to-return)) 1) then
1600                            (setf (first contents-to-return)
1601                              (list (append (list :choice)
1602                                            (first contents-to-return))))
1603                     elseif (listp (first (first contents-to-return))) then
1604                            (setf (first contents-to-return)
1605                              (first (first contents-to-return))))
1606                    (push :* (first contents-to-return))
1607             elseif (eq #\? ch) then
1608                    (setf state state-dtd-!-element-type-paren-pcd5)
1609                    (setf (first contents-to-return) (nreverse (first contents-to-return)))
1610                    (if* (> (length (first contents-to-return)) 1) then
1611                            (setf (first contents-to-return)
1612                              (list (append (list :choice)
1613                                            (first contents-to-return))))
1614                     elseif (listp (first (first contents-to-return))) then
1615                            (setf (first contents-to-return)
1616                              (first (first contents-to-return))))
1617                    (push :? (first contents-to-return))
1618             elseif (eq #\+ ch) then
1619                    (setf state state-dtd-!-element-type-paren-pcd5)
1620                    (setf (first contents-to-return) (nreverse (first contents-to-return)))
1621                    (if* (> (length (first contents-to-return)) 1) then
1622                            (setf (first contents-to-return)
1623                              (list (append (list :choice)
1624                                            (first contents-to-return))))
1625                     elseif (listp (first (first contents-to-return))) then
1626                            (setf (first contents-to-return)
1627                              (first (first contents-to-return))))
1628                    (push :+ (first contents-to-return))
1629             elseif (and external (eq #\% ch)) then
1630                    (external-param-reference tokenbuf coll external-callback)
1631             elseif (xml-space-p ch) then
1632                    (setf state state-dtd-!-element-type-paren-pcd5)
1633                    (setf (first contents-to-return) (nreverse (first contents-to-return)))
1634                    (when (> (length (first contents-to-return)) 1)
1635                      (setf (first contents-to-return)
1636                        (list (append (list :\choice)
1637                                      (first contents-to-return)))))
1638               else (dotimes (i 15)
1639                      (add-to-coll coll ch)
1640                      (setq ch (get-next-char tokenbuf))
1641                      (if* (null ch)
1642                         then (return)))
1643                    (xml-error (concatenate 'string
1644                                 "illegal DTD <!ELEMENT content spec for "
1645                                 (string (first (reverse contents-to-return)))
1646                                 ": '"
1647                                 (compute-coll-string coll)
1648                                 "'"))
1649                    ))
1650           (#.state-dtd-!-element-type-paren-name
1651            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1652             elseif (and external (eq #\% ch)) then
1653                    (external-param-reference tokenbuf coll external-callback)
1654             elseif (xml-space-p ch) then
1655                    (push (compute-tag coll) (first pending))
1656                    (clear-coll coll)
1657                    (setf state state-dtd-!-element-type-paren-name2)
1658             elseif (eq #\? ch) then
1659                    (push (compute-tag coll) (first pending))
1660                    (setf (first pending)
1661                      (list (push :? (first pending))))
1662                    (clear-coll coll)
1663                    (setf state state-dtd-!-element-type-paren-name2)
1664             elseif (eq #\* ch) then
1665                    (push (compute-tag coll) (first pending))
1666                    (setf (first pending)
1667                      (list (push :* (first pending))))
1668                    (clear-coll coll)
1669                    (setf state state-dtd-!-element-type-paren-name2)
1670             elseif (eq #\+ ch) then
1671                    (push (compute-tag coll) (first pending))
1672                    (setf (first pending)
1673                      (list (push :+ (first pending))))
1674                    (clear-coll coll)
1675                    (setf state state-dtd-!-element-type-paren-name2)
1676             elseif (eq #\) ch) then
1677                    (push (compute-tag coll) (first pending))
1678                    (clear-coll coll)
1679                    (if* (= (length pending) 1) then
1680                            (push (first pending) contents-to-return)
1681                            (setf state state-dtd-!-element-type-paren2)
1682                       else ;; this is (xxx)
1683                            (if* (second pending) then
1684                                    (push (first pending) (second pending))
1685                               else (setf (second pending) (first pending)))
1686                            (setf pending (rest pending))
1687                            (setf state state-dtd-!-element-type-paren-choice-name3)
1688                            )
1689             elseif (eq #\, ch) then
1690                    (when (and (first pending) (not (eq :seq (first pending-type))))
1691                      (clear-coll coll)
1692                      (dotimes (i 15)
1693                        (add-to-coll coll ch)
1694                        (setq ch (get-next-char tokenbuf))
1695                        (if* (null ch)
1696                           then (return)))
1697                      (xml-error (concatenate 'string
1698                                 "illegal '|' and ',' mix starting at '"
1699                                 (compute-coll-string coll)
1700                                 "'")))
1701                    (push (compute-tag coll) (first pending))
1702                    (push :seq pending-type)
1703                    (clear-coll coll)
1704                    (setf state state-dtd-!-element-type-paren-choice)
1705             elseif (eq #\| ch) then
1706                    (when (and (first pending) (not (eq :choice (first pending-type))))
1707                      (clear-coll coll)
1708                      (dotimes (i 15)
1709                        (add-to-coll coll ch)
1710                        (setq ch (get-next-char tokenbuf))
1711                        (if* (null ch)
1712                           then (return)))
1713                      (xml-error (concatenate 'string
1714                                 "illegal '|' and ',' mix starting at '"
1715                                 (compute-coll-string coll)
1716                                 "'")))
1717                    (push (compute-tag coll) (first pending))
1718                    (push :choice pending-type)
1719                    (clear-coll coll)
1720                    (setf state state-dtd-!-element-type-paren-choice)
1721               else (dotimes (i 15)
1722                      (add-to-coll coll ch)
1723                      (setq ch (get-next-char tokenbuf))
1724                      (if* (null ch)
1725                         then (return)))
1726                    (xml-error (concatenate 'string
1727                                 "illegal DTD <!ELEMENT content spec for "
1728                                 (string (first contents-to-return))
1729                                 ": '"
1730                                 (compute-coll-string coll)
1731                                 "'"))
1732                    ))
1733           (#.state-dtd-!-element-type-paren-name2
1734            (if* (xml-space-p ch) then nil
1735             elseif (and external (eq #\% ch)) then
1736                    (external-param-reference tokenbuf coll external-callback)
1737             elseif (eq #\| ch) then
1738                    (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
1739                      (clear-coll coll)
1740                      (dotimes (i 15)
1741                        (add-to-coll coll ch)
1742                        (setq ch (get-next-char tokenbuf))
1743                        (if* (null ch)
1744                           then (return)))
1745                      (xml-error (concatenate 'string
1746                                 "illegal '|' and ',' mix starting at '"
1747                                 (compute-coll-string coll)
1748                                 "'")))
1749                    (push :choice pending-type)
1750                    (setf state state-dtd-!-element-type-paren-choice)
1751             elseif (eq #\, ch) then
1752                    (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
1753                      (clear-coll coll)
1754                      (dotimes (i 15)
1755                        (add-to-coll coll ch)
1756                        (setq ch (get-next-char tokenbuf))
1757                        (if* (null ch)
1758                           then (return)))
1759                      (xml-error (concatenate 'string
1760                                 "illegal '|' and ',' mix starting at '"
1761                                 (compute-coll-string coll)
1762                                 "'")))
1763                    (push :seq pending-type)
1764                    (setf state state-dtd-!-element-type-paren-choice)
1765             elseif (eq #\) ch) then
1766                    (if* (= (length pending) 1) then
1767                            (push (list (first pending)) contents-to-return)
1768                            (setf state state-dtd-!-element-type-paren2)
1769                       else (setf pending (reverse (rest (reverse pending))))
1770                            )
1771               else (dotimes (i 15)
1772                      (add-to-coll coll ch)
1773                      (setq ch (get-next-char tokenbuf))
1774                      (if* (null ch)
1775                         then (return)))
1776                    (xml-error (concatenate 'string
1777                                 "illegal DTD <!ELEMENT content spec for "
1778                                 (string (first (reverse contents-to-return)))
1779                                 ": '"
1780                                 (compute-coll-string coll)
1781                                 "'"))
1782                    ))
1783
1784           (#.state-dtd-!-element-type-paren-choice
1785            (if* (xml-name-start-char-p ch) then
1786                    (un-next-char ch)
1787                    (setf state state-dtd-!-element-type-paren-choice-name)
1788             elseif (xml-space-p ch) then nil
1789             elseif (and external (eq #\% ch)) then
1790                    (external-param-reference tokenbuf coll external-callback)
1791             elseif (eq #\( ch) then
1792                    (push nil pending)
1793                    (setf state state-dtd-!-element-type-paren-choice-paren)
1794             elseif (eq #\) ch) then
1795                    (if* (= (length pending) 1) then
1796                            (setf (first pending) (nreverse (first pending)))
1797                            (if* (> (length (first pending)) 1) then
1798                                    (push (first pending-type) (first pending))
1799                                    (setf pending-type (rest pending-type))
1800                               else (setf (first pending) (first (first pending))))
1801                            (push (first pending) contents-to-return)
1802                            (setf state state-dtd-!-element-type-paren3)
1803                       else (setf (first pending) (nreverse (first pending)))
1804                            (if* (> (length (first pending)) 1) then
1805                                    (push (first pending-type) (first pending))
1806                                    (setf pending-type (rest pending-type))
1807                               else (setf (first pending) (first (first pending))))
1808                            (if* (second pending) then
1809                                    (push (first pending) (second pending))
1810                               else (setf (second pending) (list (first pending))))
1811                            (setf pending (rest pending))
1812                            (setf state state-dtd-!-element-type-paren-choice-name3)
1813                            )
1814               else (dotimes (i 15)
1815                      (add-to-coll coll ch)
1816                      (setq ch (get-next-char tokenbuf))
1817                      (if* (null ch)
1818                         then (return)))
1819                    (xml-error (concatenate 'string
1820                                 "illegal DTD <!ELEMENT content spec for "
1821                                 (string (first (reverse contents-to-return)))
1822                                 ": '"
1823                                 (compute-coll-string coll)
1824                                 "'"))
1825                    ))
1826
1827           (#.state-dtd-!-element-type-paren-choice-paren
1828            (if* (xml-name-start-char-p ch) then
1829                    (setf state state-dtd-!-element-type-paren-name)
1830                    (un-next-char ch)
1831             elseif (eq #\( ch) then (push nil pending)
1832             elseif (xml-space-p ch) then nil
1833             elseif (and external (eq #\% ch)) then
1834                    (external-param-reference tokenbuf coll external-callback)
1835               else (dotimes (i 15)
1836                      (add-to-coll coll ch)
1837                      (setq ch (get-next-char tokenbuf))
1838                      (if* (null ch)
1839                         then (return)))
1840                    (xml-error (concatenate 'string
1841                                 "illegal DTD <!ELEMENT content spec for "
1842                                 (string (first contents-to-return))
1843                                 ": '"
1844                                 (compute-coll-string coll)
1845                                 "'"))
1846                    ))
1847           (#.state-dtd-!-element-type-paren-choice-name
1848            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1849             elseif (and external (eq #\% ch)) then
1850                    (external-param-reference tokenbuf coll external-callback)
1851             elseif (xml-space-p ch) then
1852                    (push (compute-tag coll) (first pending))
1853                    (clear-coll coll)
1854                    (setf state state-dtd-!-element-type-paren-choice-name2)
1855             elseif (eq #\? ch) then
1856                    (push (list :? (compute-tag coll)) (first pending))
1857                    (clear-coll coll)
1858                    (setf state state-dtd-!-element-type-paren-choice-name2)
1859             elseif (eq #\* ch) then
1860                    (push (list :* (compute-tag coll)) (first pending))
1861                    (clear-coll coll)
1862                    (setf state state-dtd-!-element-type-paren-choice-name2)
1863             elseif (eq #\+ ch) then
1864                    (push (list :+ (compute-tag coll)) (first pending))
1865                    (clear-coll coll)
1866                    (setf state state-dtd-!-element-type-paren-choice-name2)
1867             elseif (eq #\) ch) then
1868                    (push (compute-tag coll) (first pending))
1869                    (clear-coll coll)
1870                    (if* (= (length pending) 1) then
1871                            (setf (first pending) (nreverse (first pending)))
1872                            (if* (> (length (first pending)) 1) then
1873                                    (push (first pending-type) (first pending))
1874                                    (setf pending-type (rest pending-type))
1875                               else (setf (first pending) (first (first pending))))
1876                            (push (first pending) contents-to-return)
1877                            (setf state state-dtd-!-element-type-paren3)
1878                       else (setf (first pending) (nreverse (first pending)))
1879                            (push (first pending-type) (first pending))
1880                            (setf pending-type (rest pending-type))
1881                            (if* (second pending) then
1882                                    (push (first pending) (second pending))
1883                               else (setf (second pending)
1884                                      ;; (list (first pending)) ;2001-03-22
1885                                      (first pending) ;2001-03-22
1886                                      ))
1887                            (setf pending (rest pending))
1888                            (setf state state-dtd-!-element-type-paren-choice-name3)
1889                            )
1890             elseif (eq #\, ch) then
1891                    (when (and (first pending) (not (eq :seq (first pending-type))))
1892                      (clear-coll coll)
1893                      (dotimes (i 15)
1894                        (add-to-coll coll ch)
1895                        (setq ch (get-next-char tokenbuf))
1896                        (if* (null ch)
1897                           then (return)))
1898                      (xml-error (concatenate 'string
1899                                 "illegal '|' and ',' mix starting at '"
1900                                 (compute-coll-string coll)
1901                                 "'")))
1902                    (push (compute-tag coll) (first pending))
1903                    (clear-coll coll)
1904                    (push :seq pending-type)
1905                    (setf state state-dtd-!-element-type-paren-choice)
1906             elseif (eq #\| ch) then
1907                    (when (and (first pending) (not (eq :choice (first pending-type))))
1908                      (clear-coll coll)
1909                      (dotimes (i 15)
1910                        (add-to-coll coll ch)
1911                        (setq ch (get-next-char tokenbuf))
1912                        (if* (null ch)
1913                           then (return)))
1914                      (xml-error (concatenate 'string
1915                                 "illegal '|' and ',' mix starting at '"
1916                                 (compute-coll-string coll)
1917                                 "'")))
1918                    (push (compute-tag coll) (first pending))
1919                    (clear-coll coll)
1920                    (push :choice pending-type)
1921                    (setf state state-dtd-!-element-type-paren-choice)
1922               else (dotimes (i 15)
1923                      (add-to-coll coll ch)
1924                      (setq ch (get-next-char tokenbuf))
1925                      (if* (null ch)
1926                         then (return)))
1927                    (xml-error (concatenate 'string
1928                                 "illegal DTD <!ELEMENT content spec for "
1929                                 (string (first contents-to-return))
1930                                 ": '"
1931                                 (compute-coll-string coll)
1932                                 "'"))
1933                    ))
1934           (#.state-dtd-!-element-type-paren-choice-name2
1935            (if* (eq #\| ch)
1936                    ;; begin changes 2001-03-22
1937               then (setf state state-dtd-!-element-type-paren-choice)
1938                    (push :choice pending-type)
1939             elseif (eq #\, ch)
1940               then (setf state state-dtd-!-element-type-paren-choice)
1941                    (push :seq pending-type)
1942                    ;; end changes 2001-03-22
1943             elseif (xml-space-p ch) then nil
1944             elseif (and external (eq #\% ch)) then
1945                    (external-param-reference tokenbuf coll external-callback)
1946             elseif (eq #\) ch) then
1947                    (if* (= (length pending) 1) then
1948                            (setf (first pending) (nreverse (first pending)))
1949                            (if* (> (length (first pending)) 1) then
1950                                    (push (first pending-type) (first pending))
1951                                    (setf pending-type (rest pending-type))
1952                               else (setf (first pending) (first (first pending))))
1953                            (push (first pending) contents-to-return)
1954                            (setf state state-dtd-!-element-type-paren3)
1955                       else (setf (first pending) (nreverse (first pending)))
1956                            (push (first pending-type) (first pending))
1957                            (setf pending-type (rest pending-type))
1958                            (if* (second pending) then
1959                                    (push (first pending) (second pending))
1960                               else (setf (second pending) (list (first pending))))
1961                            (setf state state-dtd-!-element-type-paren-choice-name3)
1962                            )
1963                    (setf pending (rest pending))
1964               else (dotimes (i 15)
1965                      (add-to-coll coll ch)
1966                      (setq ch (get-next-char tokenbuf))
1967                      (if* (null ch)
1968                         then (return)))
1969                    (xml-error (concatenate 'string
1970                                 "illegal DTD <!ELEMENT content spec for "
1971                                 (string (first contents-to-return))
1972                                 ": '"
1973                                 (compute-coll-string coll)
1974                                 "'"))
1975                    ))
1976           (#.state-dtd-!-element-type-paren-choice-name3
1977            (if* (xml-space-p ch) then nil
1978             elseif (and external (eq #\% ch)) then
1979                    (external-param-reference tokenbuf coll external-callback)
1980             elseif (eq #\? ch) then
1981                    (setf (first pending) (list :? (first pending)))
1982                    (setf state state-dtd-!-element-type-paren-choice-name2)
1983             elseif (eq #\* ch) then
1984                    (setf (first pending) (list :* (first pending)))
1985                    (setf state state-dtd-!-element-type-paren-choice-name2)
1986             elseif (eq #\+ ch) then
1987                    (setf (first pending) (list :+ (first pending)))
1988                    (setf state state-dtd-!-element-type-paren-choice-name2)
1989             elseif (eq #\) ch) then
1990                    (if* (= (length pending) 1) then
1991                            (setf (first pending) (nreverse (first pending)))
1992                            (if* (> (length (first pending)) 1) then
1993                                    (push (first pending-type) (first pending))
1994                                    (setf pending-type (rest pending-type))
1995                               else (setf (first pending) (first (first pending))))
1996                            (push (first pending) contents-to-return)
1997                            (setf pending (rest pending))
1998                            (setf state state-dtd-!-element-type-paren3)
1999                       else (setf (first pending) (nreverse (first pending)))
2000                            (if* (> (length (first pending)) 1) then
2001                                    (push (first pending-type) (first pending))
2002                                    (setf pending-type (rest pending-type))
2003                               else (setf (first pending) (first (first pending))))
2004                            (if* (second pending) then
2005                                    (push (first pending) (second pending))
2006                               else (setf (second pending) (list (first pending))))
2007                            (setf pending (rest pending))
2008                            (setf state state-dtd-!-element-type-paren-choice)
2009                            )
2010             elseif (eq #\, ch) then
2011                    (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
2012                      (clear-coll coll)
2013                      (dotimes (i 15)
2014                        (add-to-coll coll ch)
2015                        (setq ch (get-next-char tokenbuf))
2016                        (if* (null ch)
2017                           then (return)))
2018                      (xml-error (concatenate 'string
2019                                 "illegal '|' and ',' mix starting at '"
2020                                 (compute-coll-string coll)
2021                                 "'")))
2022                    (push :seq pending-type)
2023                    (setf state state-dtd-!-element-type-paren-choice)
2024             elseif (eq #\| ch) then
2025                    (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
2026                      (clear-coll coll)
2027                      (dotimes (i 15)
2028                        (add-to-coll coll ch)
2029                        (setq ch (get-next-char tokenbuf))
2030                        (if* (null ch)
2031                           then (return)))
2032                      (xml-error (concatenate 'string
2033                                 "illegal '|' and ',' mix starting at '"
2034                                 (compute-coll-string coll)
2035                                 "'")))
2036                    (push :choice pending-type)
2037                    (setf state state-dtd-!-element-type-paren-choice)
2038               else (dotimes (i 15)
2039                      (add-to-coll coll ch)
2040                      (setq ch (get-next-char tokenbuf))
2041                      (if* (null ch)
2042                         then (return)))
2043                    (xml-error (concatenate 'string
2044                                 "illegal DTD <!ELEMENT content spec for "
2045                                 (string (first contents-to-return))
2046                                 ": '"
2047                                 (compute-coll-string coll)
2048                                 "'"))
2049                    ))
2050           (#.state-dtd-!-element-type-paren3
2051            (if* (eq #\+ ch) then
2052                    (setf (first contents-to-return)
2053                      (append (list :+) (list (first contents-to-return))))
2054                    (setf state state-dtd-!-element-type-paren-pcd5)
2055             elseif (eq #\? ch) then
2056                    (setf (first contents-to-return)
2057                      (append (list :?) (list (first contents-to-return))))
2058                    (setf state state-dtd-!-element-type-paren-pcd5)
2059             elseif (eq  #\* ch) then
2060                    (setf (first contents-to-return)
2061                      (append (list :*) (list (first contents-to-return))))
2062                    (setf state state-dtd-!-element-type-paren-pcd5)
2063             elseif (and external (eq #\% ch)) then
2064                    (external-param-reference tokenbuf coll external-callback)
2065             elseif (xml-space-p ch) then
2066                    (setf state state-dtd-!-element-type-paren-pcd5)
2067             elseif (eq #\> ch) then (return)
2068               else (dotimes (i 15)
2069                      (add-to-coll coll ch)
2070                      (setq ch (get-next-char tokenbuf))
2071                      (if* (null ch)
2072                         then (return)))
2073                    (xml-error (concatenate 'string
2074                                 "illegal DTD <!ELEMENT content spec for "
2075                                 (string (first (reverse contents-to-return)))
2076                                 ": '"
2077                                 (compute-coll-string coll)
2078                                 "'"))
2079                    ))
2080           (#.state-dtd-!-element-type-paren-pcd
2081            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2082             elseif (and external (eq #\% ch)) then
2083                    (external-param-reference tokenbuf coll external-callback)
2084             elseif (xml-space-p ch) then
2085                     (let ((token (compute-tag coll)))
2086                      (when (not (eq token :PCDATA))
2087                        (xml-error (concatenate 'string
2088                                     "illegal DTD <!ELEMENT content spec for "
2089                                     (string (first contents-to-return))
2090                                     ": '"
2091                                     (compute-coll-string coll)
2092                                     "'")))
2093                      (clear-coll coll)
2094                      (push token contents-to-return))
2095                    (setf state state-dtd-!-element-type-paren-pcd2)
2096             elseif (eq #\| ch) then
2097                    (let ((token (compute-tag coll)))
2098                      (when (not (eq token :PCDATA))
2099                        (xml-error (concatenate 'string
2100                                     "illegal DTD <!ELEMENT content spec for "
2101                                     (string (first contents-to-return))
2102                                     ": '"
2103                                     (compute-coll-string coll)
2104                                     "'")))
2105                      (push token contents-to-return))
2106                    (clear-coll coll)
2107                    (setf state state-dtd-!-element-type-paren-pcd3)
2108             elseif (eq #\) ch) then
2109                    (let ((token (compute-tag coll)))
2110                      (when (not (eq token :PCDATA))
2111                        (xml-error (concatenate 'string
2112                                     "illegal DTD <!ELEMENT content spec for "
2113                                     (string (first contents-to-return))
2114                                     ": '"
2115                                     (compute-coll-string coll)
2116                                     "'")))
2117                      (push token contents-to-return))
2118                    (setf state state-dtd-!-element-type-paren-pcd4)
2119               else (dotimes (i 15)
2120                      (add-to-coll coll ch)
2121                      (setq ch (get-next-char tokenbuf))
2122                      (if* (null ch)
2123                         then (return)))
2124                    (xml-error (concatenate 'string
2125                                 "illegal DTD <!ELEMENT content spec for "
2126                                 (string (first contents-to-return))
2127                                 ": '"
2128                                 (compute-coll-string coll)
2129                                 "'"))
2130                    ))
2131           (#.state-dtd-!-element-type-paren-pcd2
2132            (if* (xml-space-p ch) then nil
2133             elseif (and external (eq #\% ch)) then
2134                    (external-param-reference tokenbuf coll external-callback)
2135             elseif (eq #\) ch) then
2136                    (setf state state-dtd-!-element-type-paren-pcd4)
2137             elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2138               else (dotimes (i 15)
2139                      (add-to-coll coll ch)
2140                      (setq ch (get-next-char tokenbuf))
2141                      (if* (null ch)
2142                         then (return)))
2143                    (xml-error (concatenate 'string
2144                                 "illegal DTD <!ELEMENT content spec for "
2145                                 (string (first (reverse contents-to-return)))
2146                                 ": '"
2147                                 (compute-coll-string coll)
2148                                 "'"))
2149                    ))
2150           (#.state-dtd-!-element-type-paren-pcd3
2151            (if* (xml-space-p ch) then nil
2152             elseif (and external (eq #\% ch)) then
2153                    (external-param-reference tokenbuf coll external-callback)
2154             elseif (xml-name-start-char-p ch) then
2155                    (un-next-char ch)
2156                    (setf state state-dtd-!-element-type-paren-pcd7)
2157               else (dotimes (i 15)
2158                      (add-to-coll coll ch)
2159                      (setq ch (get-next-char tokenbuf))
2160                      (if* (null ch)
2161                         then (return)))
2162                    (xml-error (concatenate 'string
2163                                 "illegal DTD <!ELEMENT content spec for "
2164                                 (string (first (reverse contents-to-return)))
2165                                 ": '"
2166                                 (compute-coll-string coll)
2167                                 "'"))
2168                    ))
2169           (#.state-dtd-!-element-type-paren-pcd4
2170            (if* (xml-space-p ch) then
2171                    (setf state state-dtd-!-element-type-paren-pcd6)
2172             elseif (and external (eq #\% ch)) then
2173                    (external-param-reference tokenbuf coll external-callback)
2174             elseif (eq #\* ch) then
2175                    (setf (first contents-to-return) '(:* :PCDATA))
2176                    (setf state state-dtd-!-element-type-paren-pcd5)
2177             elseif (eq #\> ch) then (return)
2178               else (clear-coll coll)
2179                    (dotimes (i 15)
2180                      (add-to-coll coll ch)
2181                      (setq ch (get-next-char tokenbuf))
2182                      (if* (null ch)
2183                         then (return)))
2184                    (xml-error (concatenate 'string
2185                                 "illegal DTD contents following <!ELEMENT content spec for "
2186                                 (string (first (reverse contents-to-return)))
2187                                 ": '"
2188                                 (compute-coll-string coll)
2189                                 "'"))
2190                    ))
2191           (#.state-dtd-!-element-type-paren-pcd5
2192            (if* (xml-space-p ch) then nil
2193             elseif (and external (eq #\% ch)) then
2194                    (external-param-reference tokenbuf coll external-callback)
2195             elseif (eq #\> ch) then (return)
2196               else (clear-coll coll)
2197                    (dotimes (i 15)
2198                      (add-to-coll coll ch)
2199                      (setq ch (get-next-char tokenbuf))
2200                      (if* (null ch)
2201                         then (return)))
2202                    (xml-error (concatenate 'string
2203                                 "illegal DTD contents following <!ELEMENT content spec for "
2204                                 (string (first (reverse contents-to-return)))
2205                                 ": '"
2206                                 (compute-coll-string coll)
2207                                 "'"))
2208                    ))
2209           (#.state-dtd-!-element-type-paren-pcd6
2210            (if* (xml-space-p ch) then nil
2211             elseif (and external (eq #\% ch)) then
2212                    (external-param-reference tokenbuf coll external-callback)
2213             elseif (eq #\> ch) then (return)
2214               else (clear-coll coll)
2215                    (dotimes (i 15)
2216                      (add-to-coll coll ch)
2217                      (setq ch (get-next-char tokenbuf))
2218                      (if* (null ch)
2219                         then (return)))
2220                    (xml-error (concatenate 'string
2221                                 "illegal DTD contents following <!ELEMENT content spec for "
2222                                 (string (first (reverse contents-to-return)))
2223                                 ": '"
2224                                 (compute-coll-string coll)
2225                                 "'"))
2226                    ))
2227           (#.state-dtd-!-element-type-paren-pcd7
2228            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2229             elseif (and external (eq #\% ch)) then
2230                    (external-param-reference tokenbuf coll external-callback)
2231             elseif (xml-space-p ch) then
2232                    (setf state state-dtd-!-element-type-paren-pcd8)
2233                    (let ((token (compute-tag coll)))
2234                      (clear-coll coll)
2235                      (if* (listp (first contents-to-return)) then
2236                              (push token (first contents-to-return))
2237                         else (setf (first contents-to-return)
2238                                (list token (first contents-to-return)))))
2239             elseif (eq #\) ch) then
2240                    (setf state  state-dtd-!-element-type-paren-pcd9)
2241                    (let ((token (compute-tag coll)))
2242                      (clear-coll coll)
2243                      (if* (listp (first contents-to-return)) then
2244                              (push token (first contents-to-return))
2245                         else (setf (first contents-to-return)
2246                                (list token (first contents-to-return)))))
2247               else (clear-coll coll)
2248                    (dotimes (i 15)
2249                      (add-to-coll coll ch)
2250                      (setq ch (get-next-char tokenbuf))
2251                      (if* (null ch)
2252                         then (return)))
2253                    (xml-error (concatenate 'string
2254                                 "illegal DTD contents in <!ELEMENT content spec for "
2255                                 (string (first (reverse contents-to-return)))
2256                                 ": '"
2257                                 (compute-coll-string coll)
2258                                 "'"))
2259                    ))
2260           (#.state-dtd-!-element-type-paren-pcd8
2261            (if* (xml-space-p ch) then nil
2262             elseif (and external (eq #\% ch)) then
2263                    (external-param-reference tokenbuf coll external-callback)
2264             elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2265             elseif (eq #\) ch) then (setf state state-dtd-!-element-type-paren-pcd9)
2266               else (clear-coll coll)
2267                    (dotimes (i 15)
2268                      (add-to-coll coll ch)
2269                      (setq ch (get-next-char tokenbuf))
2270                      (if* (null ch)
2271                         then (return)))
2272                    (xml-error (concatenate 'string
2273                                 "illegal DTD contents in <!ELEMENT content spec for "
2274                                 (string (first (reverse contents-to-return)))
2275                                 ": '"
2276                                 (compute-coll-string coll)
2277                                 "'"))
2278                    ))
2279           (#.state-dtd-!-element-type-paren-pcd9
2280            (if* (eq #\* ch) then (setf state state-dtd-!-element-type-paren-pcd5)
2281                    (setf (first contents-to-return) (nreverse (first contents-to-return)))
2282                    (when (> (length (first contents-to-return)) 1)
2283                      (setf (first contents-to-return)
2284                        (list (append (list :choice)
2285                                      (first contents-to-return)))))
2286                    (push :* (first contents-to-return))
2287               else (clear-coll coll)
2288                    (dotimes (i 15)
2289                      (add-to-coll coll ch)
2290                      (setq ch (get-next-char tokenbuf))
2291                      (if* (null ch)
2292                         then (return)))
2293                    (xml-error (concatenate 'string
2294                                 "illegal DTD contents in <!ELEMENT content spec for "
2295                                 (string (first (reverse contents-to-return)))
2296                                 ": '"
2297                                 (compute-coll-string coll)
2298                                 "'"))
2299                    ))
2300           (#.state-dtd-!-element-type-token
2301            (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2302             elseif (and external (eq #\% ch)) then
2303                    (external-param-reference tokenbuf coll external-callback)
2304             elseif (xml-space-p ch) then
2305                    (let ((token (compute-tag coll)))
2306                      (when (not (or (eq token :EMPTY) (eq token :ANY)))
2307                        (xml-error (concatenate 'string
2308                                     "illegal DTD <!ELEMENT content spec for "
2309                                     (string (first contents-to-return))
2310                                     ": '"
2311                                     (compute-coll-string coll)
2312                                     "'")))
2313                      (push token contents-to-return)
2314                      (setf state state-dtd-!-element-type-end))
2315             elseif (eq #\> ch) then
2316                    (let ((token (compute-tag coll)))
2317                      (when (not (or (eq token :EMPTY) (eq token :ANY)))
2318                        (xml-error (concatenate 'string
2319                                     "illegal DTD <!ELEMENT content spec for "
2320                                     (string (first contents-to-return))
2321                                     ": '"
2322                                     (compute-coll-string coll)
2323                                     "'")))
2324                      (push token contents-to-return)
2325                      (return))
2326               else (add-to-coll coll ch)
2327                    (xml-error (concatenate 'string
2328                                 "illegal DTD <!ELEMENT content spec for "
2329                                 (string (first contents-to-return))
2330                                 ": '"
2331                                 (compute-coll-string coll)
2332                                 "'"))
2333                    )
2334            )
2335           (#.state-dtd-!-element-type-end
2336            (if* (xml-space-p ch) then nil
2337             elseif (and external (eq #\% ch)) then
2338                    (external-param-reference tokenbuf coll external-callback)
2339             elseif (eq #\> ch) then (return)
2340               else (xml-error (concatenate 'string
2341                                 "expected '>', got '"
2342                                 (string ch)
2343                                 "' in DTD <! ELEMENT "
2344                                 (string (first contents-to-return))
2345                                 " for "
2346                                 (string (second contents-to-return))))
2347                    ))
2348           (t
2349            (error "need to support dtd state:~s" state))))
2350       (put-back-collector entity)
2351       (put-back-collector coll)
2352       (case state
2353         (#.state-dtdstart
2354          (when (and (null ch) (not external))
2355            (xml-error "unexpected end of input while parsing DTD"))
2356          (if* (null tag-to-return) then (values nil :end-dtd)
2357             else (error "process other return state")))
2358         ((#.state-dtd-!-element-type-end #.state-dtd-!-element-type-token
2359           #.state-dtd-!-element-type-paren-pcd4 #.state-dtd-!-element-type-paren-pcd6
2360           #.state-dtd-!-element-type-paren-pcd5 #.state-dtd-!-element-type-paren2
2361           #.state-dtd-!-element-type-paren3)
2362          (values (append (list tag-to-return) (nreverse contents-to-return))
2363                  nil))
2364         ((#.state-dtd-!-attdef-decl-type #.state-dtd-!-attlist-name
2365           #.state-dtd-!-attdef)
2366          (values (append (list tag-to-return) contents-to-return)
2367                  nil))
2368         ((#.state-dtd-!-entity5 #.state-!-dtd-system3
2369           #.state-!-dtd-system7 #.state-!-dtd-system4
2370           #.state-!-dtd-system ;; this is actually a !NOTATION
2371           #.state-dtd-?-4 ;; PI
2372           #.state-dtd-comment4 ;; comment
2373           )
2374          (let ((ret (append (list tag-to-return) (nreverse contents-to-return))))
2375            (values ret
2376                    nil)))
2377         #+ignore
2378         (#.state-dtd-pref2
2379          (values (nreverse contents-to-return) nil))
2380         (#.state-dtd-!-include2
2381          (values nil :include))
2382         (#.state-dtd-!-include4
2383          (values nil :include-end))
2384         (#.state-dtd-!-ignore7
2385          (values nil :ignore))
2386         (:eof
2387          (if* (not external) then
2388                  (xml-error "unexpected end of input while processing DTD internal subset")
2389           elseif (or (> include-count 0) (not (eq prev-state state-dtdstart))) then
2390                  (xml-error "unexpected end of input while processing external DTD"))
2391          (values nil :end-dtd))
2392         (t
2393          (print (list tag-to-return contents-to-return))
2394          (error "need to support dtd <post> state:~s" state)))
2395       )
2396     ))
2397
2398 (defun external-param-reference (tokenbuf old-coll external-callback)
2399   (declare (:fbound next-token) (ignorable old-coll) (optimize (speed 3) (safety 1)))
2400   (setf (iostruct-seen-parameter-reference tokenbuf) t)
2401   (macrolet ((add-to-entity-buf (entity-symbol p-value)
2402                `(progn
2403                   (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
2404                         (iostruct-entity-bufs tokenbuf))))
2405              (clear-coll (coll)
2406                `(setf (collector-next ,coll) 0))
2407              (un-next-char (ch)
2408                `(push ,ch (iostruct-unget-char tokenbuf)))
2409              (add-to-coll (coll ch)
2410                `(let ((.next. (collector-next ,coll)))
2411                   (if* (>= .next. (collector-max ,coll))
2412                      then (grow-and-add ,coll ,ch)
2413                      else (setf (schar (collector-data ,coll) .next.)
2414                             ,ch)
2415                           (setf (collector-next ,coll) (1+ .next.))))))
2416     (let ((ch (get-next-char tokenbuf))
2417           (coll (get-collector))
2418           p-value entity-symbol)
2419       (add-to-coll coll ch)
2420       (when (not (xml-name-start-char-p ch))
2421         (dotimes (i 15)
2422           (add-to-coll coll ch)
2423           (setq ch (get-next-char tokenbuf))
2424           (if* (null ch)
2425              then (return)))
2426         (xml-error (concatenate 'string
2427                      "Illegal DTD parameter entity name starting at: "
2428                      (compute-coll-string coll))))
2429       (loop
2430         (setf ch (get-next-char tokenbuf))
2431         (if* (eq #\; ch) then
2432                 (setf entity-symbol (compute-tag coll))
2433                 (clear-coll coll)
2434                 #+ignore (format t "entity symbol: ~s entities: ~s match: ~s~%"
2435                                  entity-symbol (iostruct-parameter-entities tokenbuf)
2436                                  (assoc entity-symbol
2437                                         (iostruct-parameter-entities tokenbuf)))
2438                 (if* (and (iostruct-do-entity tokenbuf)
2439                           (setf p-value
2440                             (assoc entity-symbol
2441                                    (iostruct-parameter-entities tokenbuf)))) then
2442                         (setf p-value (rest p-value))
2443                         (when (member entity-symbol (iostruct-entity-names tokenbuf))
2444                           (xml-error (concatenate 'string
2445                                        "entity:"
2446                                        (string entity-symbol)
2447                                        " in recursive reference")))
2448                         (push entity-symbol (iostruct-entity-names tokenbuf))
2449                         (if* (stringp p-value) then
2450                                 (setf p-value (concatenate 'string " " p-value " "))
2451                                 (add-to-entity-buf entity-symbol p-value)
2452                          elseif (null external-callback) then
2453                                 (setf (iostruct-do-entity tokenbuf) nil)
2454                          elseif p-value then
2455                                 (let ((entity-stream (apply external-callback p-value)))
2456                                   (when entity-stream
2457                                     (let ((entity-buf (get-tokenbuf)))
2458                                       (setf (tokenbuf-stream entity-buf) entity-stream)
2459                                       (unicode-check entity-stream tokenbuf)
2460                                       (add-to-entity-buf entity-symbol " ")
2461                                       (push entity-buf
2462                                             (iostruct-entity-bufs tokenbuf))
2463                                       (let ((count 0) cch
2464                                             (string "<?xml "))
2465                                         (if* (dotimes (i (length string) t)
2466                                                (setf cch (get-next-char tokenbuf))
2467                                                (when (and (= i 5)
2468                                                           (xml-space-p cch))
2469                                                  (setf cch #\space))
2470                                                (when (not (eq cch
2471                                                               (schar string count)))
2472                                                  (return nil))
2473                                                (incf count)) then
2474                                                 (setf count 5)
2475                                                 (loop
2476                                                   (when (< count 0) (return))
2477                                                   (un-next-char (schar string count))
2478                                                   (decf count))
2479                                                 ;; swallow <?xml token
2480                                                 (next-token tokenbuf external-callback nil)
2481                                            else
2482                                                 (un-next-char cch)
2483                                                 (decf count)
2484                                                 (loop
2485                                                   (when (< count 0) (return))
2486                                                   (un-next-char (schar string count))
2487                                                   (decf count))))
2488                                       (push #\space (iostruct-unget-char tokenbuf))
2489                                       )
2490                                     )))
2491                    else (xml-error
2492                          (concatenate 'string
2493                            (string entity-symbol)
2494                            " parameter entity referenced but not declared"))
2495                         )
2496                 (put-back-collector coll)
2497                 (return)
2498          elseif (xml-name-char-p ch) then (add-to-coll coll ch)
2499            else
2500                 (dotimes (i 15)
2501                   (add-to-coll coll ch)
2502                   (setq ch (get-next-char tokenbuf))
2503                   (if* (null ch)
2504                      then (return)))
2505                 (xml-error (concatenate 'string
2506                              "Illegal DTD parameter entity name stating at: "
2507                              (compute-coll-string coll))))))))
2508
2509