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