- (case state
- (#.state-dtdstart
- (if* (and (eq #\] ch)
- external (> include-count 0)) then
- (setf state state-dtd-!-include3)
- elseif (and (eq #\] ch) (not external)) then (return)
- elseif (eq #\< ch) then (setf state state-tokenstart)
- elseif (xml-space-p ch) then nil
- elseif (eq #\% ch) then (external-param-reference tokenbuf coll external-callback)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-include3
- (if* (eq #\] ch) then (setf state state-dtd-!-include4)
- else
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD token, starting at: ']"
- (compute-coll-string coll)
- "'"))))
- (#.state-dtd-!-include4
- (if* (eq #\> ch) then (return)
- else
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD token, starting at: ']]"
- (compute-coll-string coll)
- "'"))))
- #+ignore
- (#.state-dtd-pref
- (if* (xml-name-start-char-p ch) then
- (add-to-coll coll ch)
- (setf state state-dtd-pref2)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD parameter reference name, starting at: '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-tokenstart
- (if* (eq #\? ch) then (setf state state-dtd-?)
- elseif (eq #\! ch) then (setf state state-dtd-!)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-?
- (if* (xml-name-char-p ch)
- then
- (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else
- (when (not (xml-space-p ch))
- (xml-error (concatenate 'string
- "expecting name following: '<?"
- (compute-coll-string coll)
- "' ; got: '" (string ch) "'"))
- )
- (when (= (collector-next coll) 0)
- (xml-error "null <? token"))
- (if* (and (= (collector-next coll) 3)
- (or (eq (elt (collector-data coll) 0) #\X)
- (eq (elt (collector-data coll) 0) #\x))
- (or (eq (elt (collector-data coll) 1) #\M)
- (eq (elt (collector-data coll) 1) #\m))
- (or (eq (elt (collector-data coll) 2) #\L)
- (eq (elt (collector-data coll) 2) #\l)))
- then
- (xml-error "<?xml not allowed in dtd")
- else
- (setq tag-to-return (compute-tag coll))
- (setf state state-dtd-?-2))
- (clear-coll coll)))
- (#.state-dtd-?-2
- (if* (xml-space-p ch)
- then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (not (xml-char-p ch))
- then (xml-error "XML is not well formed") ;; no test
- else (add-to-coll coll ch)
- (setf state state-dtd-?-3)))
- (#.state-dtd-?-3
- (if* (eq #\? ch)
- then (setf state state-dtd-?-4)
- elseif (not (xml-char-p ch))
- then (xml-error "XML is not well formed") ;; no test
- else (add-to-coll coll ch)))
- (#.state-dtd-?-4
- (if* (eq #\> ch)
- then
- (push (compute-coll-string coll) contents-to-return)
- (clear-coll coll)
- (return)
- else (setf state state-dtd-?-3)
- (add-to-coll coll #\?)
- (add-to-coll coll ch)))
- (#.state-dtd-!
- (if* (eq #\- ch) then (setf state state-dtd-comment)
- elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-token)
- (un-next-char ch)
- elseif (and (eq #\[ ch) external) then
- (setf state state-dtd-!-cond)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<!"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-cond
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\I ch) then (setf state state-dtd-!-cond2)
- else (error "this should not happen")
- ))
- (#.state-dtd-!-cond2
- (if* (eq #\N ch) then (setf state state-dtd-!-include)
- (setf check-count 2)
- elseif (eq #\G ch) then (setf state state-dtd-!-ignore)
- (setf check-count 2)
- else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
- ))
- (#.state-dtd-!-ignore
- (if* (and (eq check-count 5) (eq ch #\E)) then
- (setf state state-dtd-!-ignore2)
- elseif (eq ch (elt "IGNORE" check-count)) then
- (incf check-count)
- else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
- ))
- (#.state-dtd-!-ignore2
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\[ ch) then (setf state state-dtd-!-ignore3)
- (incf ignore-count)
- else (xml-error "'[' missing after '<![Ignore'")))
- (#.state-dtd-!-ignore3
- (if* (eq #\< ch) then (setf state state-dtd-!-ignore4)
- elseif (eq #\] ch) then (setf state state-dtd-!-ignore5)))
- (#.state-dtd-!-ignore4
- (if* (eq #\! ch) then (setf state state-dtd-!-ignore6)
- else (un-next-char ch)
- (setf state state-dtd-!-ignore3)))
- (#.state-dtd-!-ignore5
- (if* (eq #\] ch) then (setf state state-dtd-!-ignore7)
- else (un-next-char ch)
- (setf state state-dtd-!-ignore3)))
- (#.state-dtd-!-ignore6
- (if* (eq #\[ ch) then (incf ignore-count)
- (setf state state-dtd-!-ignore3)
- else (un-next-char ch)
- (setf state state-dtd-!-ignore3)))
- (#.state-dtd-!-ignore7
- (if* (eq #\> ch) then (decf ignore-count)
- (when (= ignore-count 0) (return))
- else (un-next-char ch)
- (setf state state-dtd-!-ignore3)))
- (#.state-dtd-!-include
- (if* (and (eq check-count 6) (eq ch #\E)) then
- (setf state state-dtd-!-include2)
- elseif (eq ch (elt "INCLUD" check-count)) then
- (incf check-count)
- else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
- ))
- (#.state-dtd-!-include2
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\[ ch) then (return)
- else (xml-error "'[' missing after '<![INCLUDE'")))
- (#.state-dtd-comment
- (if* (eq #\- ch)
- then (setf state state-dtd-comment2)
- (setf tag-to-return :comment)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal token following '<![-', starting at '<!-"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-comment2
- (if* (eq #\- ch)
- then (setf state state-dtd-comment3)
- else (add-to-coll coll ch)))
- (#.state-dtd-comment3
- (if* (eq #\- ch)
- then (setf state state-dtd-comment4)
- else (setf state state-dtd-comment2)
- (add-to-coll coll #\-) (add-to-coll coll ch)))
- (#.state-dtd-comment4
- (if* (eq #\> ch)
- then (push (compute-coll-string coll) contents-to-return)
- (clear-coll coll)
- (return)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal token following '--' comment terminator, starting at '--"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-token
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (setf tag-to-return (compute-tag coll))
- (clear-coll coll)
- (if* (eq tag-to-return :ELEMENT) then (setf state state-dtd-!-element)
- elseif (eq tag-to-return :ATTLIST) then
- (setf state state-dtd-!-attlist)
- elseif (eq tag-to-return :ENTITY) then
- (setf entityp t)
- (setf state state-dtd-!-entity)
- elseif (eq tag-to-return :NOTATION) then
- (setf state state-dtd-!-notation)
- else
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<!"
- (string tag-to-return)
- "'")))
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<!"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-notation
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (add-to-coll coll ch)
- (setf state state-dtd-!-notation2)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<!NOTATION "
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-notation2
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll) contents-to-return)
- (clear-coll coll)
- (setf state state-dtd-!-notation3)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!NOTATION name: "
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-notation3
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-char-p ch) then
- (add-to-coll coll ch)
- (setf state state-dtd-!-entity6)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!NOTATION spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-entity
- (if* (eq #\% ch) then (push :param contents-to-return)
- (setf pentityp t)
- (setf state state-dtd-!-entity2)
- elseif (xml-name-start-char-p ch) then
- (add-to-coll coll ch)
- (setf pending nil)
- (setf state state-dtd-!-entity3)
- elseif (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<!ENTITY "
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-entity2
- (if* (xml-space-p ch) then (setf state state-dtd-!-entity7)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-entity3
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll) contents-to-return)
- (setf contents-to-return
- (nreverse contents-to-return))
- (clear-coll coll)
- (setf state state-dtd-!-entity4)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY name: "
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-entity4
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (or (eq #\' ch) (eq #\" ch)) then
- (setf value-delim ch)
- (setf state state-dtd-!-entity-value)
- elseif (xml-name-start-char-p ch) then
- (add-to-coll coll ch)
- (setf state state-dtd-!-entity6)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY spec: '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-entity6
- (if* (xml-name-char-p ch) ;; starting char already passed more restrictive test
- then
- (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else
- (when (not (xml-space-p ch))
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error
- (concatenate 'string
- "illegal character in '"
- (compute-coll-string coll)
- "' in <! tag: " (string tag-to-return) " "
- (string (first contents-to-return))
- ))
- )
- (let ((token (compute-tag coll)))
- (push token contents-to-return)
- (clear-coll coll)
- (if* (eq :SYSTEM token) then (setf state state-!-dtd-system)
- elseif (eq :PUBLIC token) then (setf state state-!-dtd-public)
- else (xml-error
- (concatenate 'string
- "expected 'SYSTEM' or 'PUBLIC' got '"
- (string (first contents-to-return))
- "' in <! tag: " (string tag-to-return) " "
- (string (second contents-to-return))))
- )
- )))
- (#.state-dtd-!-entity7
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (add-to-coll coll ch)
- (setf state state-dtd-!-entity3)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY % name: "
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-!-dtd-public
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (or (eq #\" ch) (eq #\' ch)) then
- (setf state state-!-dtd-public2)
- (setf value-delim ch)
- else (xml-error
- (concatenate 'string
- "expected quote or double-quote got: '"
- (string ch)
- "' in <! tag: " (string tag-to-return) " "
- (string (second contents-to-return)) " "
- (string (first contents-to-return))
- ))))
- (#.state-!-dtd-public2
- (if* (eq value-delim ch) then
- (push (setf public-string
- (normalize-public-value
- (compute-coll-string coll))) contents-to-return)
- (clear-coll coll)
- (setf state state-!-dtd-public3)
- elseif (pub-id-char-p ch) then (add-to-coll coll ch)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error
- (concatenate 'string
- "illegal character in string: '"
- (compute-coll-string coll) "'"))
- ))
- (#.state-!-dtd-public3
- (if* (xml-space-p ch) then (setf state state-!-dtd-system)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (and (not entityp)
- (eq #\> ch)) then
- (setf state state-!-dtd-system)
- (return)
- else
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error
- (concatenate 'string
- "Expected space before: '"
- (compute-coll-string coll) "'"))
- ))
- (#.state-!-dtd-system
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (or (eq #\" ch) (eq #\' ch)) then
- (setf state state-!-dtd-system2)
- (setf value-delim ch)
- elseif (and (not entityp)
- (eq #\> ch)) then (return)
- else (xml-error
- (concatenate 'string
- "expected quote or double-quote got: '"
- (string ch)
- "' in <! tag: " (string tag-to-return) " "
- (string (second contents-to-return)) " "
- (string (first contents-to-return))
- ))))
- (#.state-!-dtd-system2
- (when (not (xml-char-p ch))
- (xml-error "XML is not well formed")) ;; not tested
- (if* (eq value-delim ch) then
- (let ((entity-symbol (first (last contents-to-return)))
- (system-string (compute-coll-string coll)))
- (if* pentityp then
- (when (not (assoc entity-symbol (iostruct-parameter-entities tokenbuf)))
- (setf (iostruct-parameter-entities tokenbuf)
- (acons entity-symbol (list (parse-uri system-string)
- tag-to-return
- public-string)
- (iostruct-parameter-entities tokenbuf)))
- )
- else
- (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
- (setf (iostruct-general-entities tokenbuf)
- (acons entity-symbol (list (parse-uri system-string)
- tag-to-return
- public-string
- )
- (iostruct-general-entities tokenbuf)))
- (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
- (setf (iostruct-general-entities tokenbuf)
- (acons entity-symbol (list (parse-uri system-string)
- tag-to-return
- public-string
- )
- (iostruct-general-entities tokenbuf))))
- )
- )
- (push system-string contents-to-return))
- (clear-coll coll)
- (setf state state-!-dtd-system3)
- else (add-to-coll coll ch)))
- (#.state-!-dtd-system3
- (if* (xml-space-p ch) then (setf state state-!-dtd-system4)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\> ch) then (return)
- else
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY value for "
- (string (first (nreverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-!-dtd-system4
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (and (not pentityp) (xml-name-start-char-p ch)) then
- (add-to-coll coll ch)
- (setf state state-!-dtd-system5)
- elseif (eq #\> ch) then (return)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY value for "
- (string (first (nreverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-!-dtd-system5
- (if* (xml-name-char-p ch) then
- (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (let ((token (compute-tag coll)))
- (when (not (eq :NDATA token))
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY value for "
- (string (first (nreverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- )
- (clear-coll coll)
- (push token contents-to-return)
- (setf state state-!-dtd-system6))
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY value for "
- (string (first (nreverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-!-dtd-system6
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (add-to-coll coll ch)
- (setf state state-!-dtd-system7)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY value for "
- (string (first (nreverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-!-dtd-system7
- (if* (xml-name-char-p ch) then
- (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll) contents-to-return)
- (clear-coll coll)
- (setf state state-dtd-!-entity5) ;; just looking for space, >
- elseif (eq #\> ch) then
- (push (compute-tag coll) contents-to-return)
- (clear-coll coll)
- (return)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY value for "
- (string (first (nreverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-entity-value
- (if* (eq ch value-delim) then
- (let ((tmp (compute-coll-string coll)))
- (when (> (length tmp) 0)
- (when (null (first pending)) (setf pending (rest pending)))
- (push tmp pending)))
- (if* (> (length pending) 1) then
- (push (nreverse pending) contents-to-return)
- else (push (first pending) contents-to-return))
- (setf pending (list nil))
- (setf state state-dtd-!-entity5)
- (clear-coll coll)
- (if* pentityp then
- (when (not (assoc (third contents-to-return)
- (iostruct-parameter-entities tokenbuf)))
- (setf (iostruct-parameter-entities tokenbuf)
- (acons (third contents-to-return)
- (first contents-to-return)
- (iostruct-parameter-entities tokenbuf))))
- else
- (when (not (assoc (second contents-to-return)
- (iostruct-general-entities tokenbuf)))
- (setf (iostruct-general-entities tokenbuf)
- (acons (second contents-to-return)
- (first contents-to-return)
- (iostruct-general-entities tokenbuf)))))
- elseif (eq #\& ch) then
- (setf reference-save-state state-dtd-!-entity-value)
- (setf state state-dtd-!-attdef-decl-value3)
- elseif (eq #\% ch) then
- (setf prefp t)
- (setf reference-save-state state-dtd-!-entity-value)
- (setf state state-dtd-!-attdef-decl-value3)
- elseif (xml-char-p ch)
- then (add-to-coll coll ch)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ENTITY value for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-entity5
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\> ch) then (return)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD contents following <!ENTITY spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attlist
- (if* (xml-name-start-char-p ch) then (setf state state-dtd-!-attlist-name)
- (un-next-char ch)
- elseif (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<!ATTLIST "
- (compute-coll-string coll)
- "'"))))
- (#.state-dtd-!-attlist-name
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll *package*)
- contents-to-return)
- (clear-coll coll)
- (setf state state-dtd-!-attdef)
- elseif (eq #\> ch) then
- (push (compute-tag coll *package*)
- contents-to-return)
- (clear-coll coll)
- (return)
- else (push (compute-tag coll)
- contents-to-return)
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (un-next-char ch)
- (setf state state-dtd-!-attdef-name)
- elseif (eq #\> ch) then (return)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-name
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (setf (first pending) (compute-tag coll *package*))
- (clear-coll coll)
- (setf state state-dtd-!-attdef-type)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-type
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else (un-next-char ch)
- ;; let next state do all other checking
- (setf state state-dtd-!-attdef-type2)))
- (#.state-dtd-!-attdef-type2
- ;; can only be one of a few tokens, but wait until token built to check
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and (eq #\( ch) (= 0 (length (compute-coll-string coll)))) then
- (push (list :enumeration) pending)
- (setf state state-dtd-!-attdef-notation2)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (let ((token (compute-tag coll)))
- (when (and (not (eq :CDATA token))
- (not (eq :ID token))
- (not (eq :IDREF token))
- (not (eq :IDREFS token))
- (not (eq :ENTITY token))
- (not (eq :ENTITIES token))
- (not (eq :NMTOKEN token))
- (not (eq :NMTOKENS token))
- (not (eq :NOTATION token)))
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (if* (eq token :NOTATION) then
- (push (list token) pending)
- (setf state state-dtd-!-attdef-notation)
- else
- (push token pending)
- (setf state state-dtd-!-attdef-decl))
- )
- (clear-coll coll)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-notation
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\( ch) then (setf state state-dtd-!-attdef-notation2)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-notation2
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (setf state state-dtd-!-attdef-notation3)
- (add-to-coll coll ch)
- elseif (and (xml-name-char-p ch) (listp (first pending))
- (eq :enumeration (first (reverse (first pending))))) then
- (setf state state-dtd-!-attdef-notation3)
- (add-to-coll coll ch)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-notation3
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (setf state state-dtd-!-attdef-notation4)
- elseif (eq #\| ch) then
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (setf state state-dtd-!-attdef-notation2)
- elseif (eq #\) ch) then
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (setf (first pending) (nreverse (first pending)))
- ;;(setf state state-dtd-!-attdef-decl)
- (setf state state-dtd-!-attdef-notation5)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-notation5
- (if* (xml-space-p ch) then (setf state state-dtd-!-attdef-decl)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error
- (concatenate 'string
- "Expected space before: '"
- (compute-coll-string coll) "'"))))
- (#.state-dtd-!-attdef-notation4
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-char-p ch) then (add-to-coll coll ch)
- (setf state state-dtd-!-attdef-notation3)
- elseif (eq #\| ch) then (setf state state-dtd-!-attdef-notation2)
- elseif (eq #\) ch) then (setf state state-dtd-!-attdef-decl)
- (setf (first pending) (nreverse (first pending)))
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-decl
- (if* (eq #\# ch) then
- (setf state state-dtd-!-attdef-decl-type)
- elseif (or (eq #\' ch) (eq #\" ch)) then
- (setf value-delim ch)
- (setf state state-dtd-!-attdef-decl-value)
- elseif (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-decl-value
- (if* (eq ch value-delim) then
- #-ignore
- (push (first (parse-default-value (list (compute-coll-string coll))
- tokenbuf external-callback))
- pending)
- #+ignore
- (push (compute-coll-string coll) pending)
- (setf contents-to-return
- (append contents-to-return
- (if* entityp then
- (nreverse pending)
- else (list (nreverse pending)))))
- (setf pending (list nil))
- (setf state state-dtd-!-attdef)
- (clear-coll coll)
- elseif (eq #\& ch) then (setf state state-dtd-!-attdef-decl-value3)
- (setf reference-save-state state-dtd-!-attdef-decl-value)
- elseif (and (xml-char-p ch) (not (eq #\< ch)))
- then (add-to-coll coll ch)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-decl-value3
- (if* (and (not prefp) (eq #\# ch))
- then (setf state state-dtd-!-attdef-decl-value4)
- elseif (xml-name-start-char-p ch)
- then (setf state state-dtd-!-attdef-decl-value5)
- (when (not prefp) (add-to-coll coll #\&))
- (un-next-char ch)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal reference name, starting at: '&"
- (compute-coll-string coll)
- "'"))))
- (#.state-dtd-!-attdef-decl-value4
- (if* (eq #\x ch)
- then (setf state state-dtd-!-attdef-decl-value6)
- elseif (<= (char-code #\0) (char-code ch) (char-code #\9))
- then (setf state state-dtd-!-attdef-decl-value7)
- (un-next-char ch)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal character reference code, starting at: '&#"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-attdef-decl-value5
- (if* (xml-name-char-p ch)
- then (add-to-coll entity ch)
- (when (not prefp) (add-to-coll coll ch))
- elseif (eq #\; ch)
- then
- (if* (not prefp) then (add-to-coll coll ch)
- elseif (not external) then
- (xml-error
- (concatenate 'string
- "internal dtd subset cannot reference parameter entity within a token; entity: "
- (compute-coll-string entity)))
- else
- (let* ((entity-symbol (compute-tag entity))
- (p-value
- (assoc entity-symbol (iostruct-parameter-entities tokenbuf))))
- (clear-coll entity)
- (if* (and (iostruct-do-entity tokenbuf)
- (setf p-value
- (assoc entity-symbol
- (iostruct-parameter-entities tokenbuf)))) then
- (setf p-value (rest p-value))
- (when (member entity-symbol (iostruct-entity-names tokenbuf))
- (xml-error (concatenate 'string
- "entity:"
- (string entity-symbol)
- " in recursive reference")))
- (push entity-symbol (iostruct-entity-names tokenbuf))
- (if* (stringp p-value) then
- (dotimes (i (length p-value))
- (add-to-coll coll (schar p-value i)))
- elseif p-value then
- (if* (null external-callback) then
- (setf (iostruct-do-entity tokenbuf) nil)
- else
- (let ((count 0) (string "<?xml ") last-ch
- save-ch save-unget
- (tmp-count 0)
- (entity-stream
- (apply external-callback p-value)))
- (when entity-stream
- (let ((tmp-buf (get-tokenbuf)))
- (setf (tokenbuf-stream tmp-buf)
- entity-stream)
- (setf save-unget
- (iostruct-unget-char tokenbuf))
- (setf (iostruct-unget-char tokenbuf) nil)
- (unicode-check entity-stream tokenbuf)
- (when (iostruct-unget-char tokenbuf)
- (setf save-ch (first (iostruct-unget-char tokenbuf))))
- (setf (iostruct-unget-char tokenbuf) save-unget)
- (loop
- (let ((cch
- (if* save-ch
- then
- (let ((s2 save-ch))
- (setf save-ch nil)
- s2)
- else
- (next-char
- tmp-buf
- (iostruct-read-sequence-func
- tokenbuf)))))
- (when (null cch) (return))
- (when *debug-dtd*
- (format t "dtd-char: ~s~%" cch))
- (if* (< count 0) then
- (if* (and (eq last-ch #\?)
- (eq cch #\>)) then
- (setf count 6)
- else (setf last-ch cch))
- elseif (< count 6) then
- (when (and (= count 5)
- (xml-space-p cch))
- (setf cch #\space))
- (if* (not (eq cch
- (schar string count)
- )) then
- (loop
- (when (= tmp-count count)
- (return))
- (add-to-coll coll
- (schar string
- tmp-count))
- (incf tmp-count))
- (add-to-coll coll cch)
- (setf count 10)
- else (incf count))
- elseif (= count 6) then
- (dotimes (i 6)
- (add-to-coll coll (schar string i)))
- (setf count 10)
- else (add-to-coll coll cch))))
- (setf (iostruct-entity-names tokenbuf)
- (rest (iostruct-entity-names tokenbuf)))
- (close entity-stream)
- (put-back-tokenbuf tmp-buf)))))
- )
- (setf state state-dtdstart)
- else nil
- )))
- (setf state reference-save-state)
- else (let ((tmp (compute-coll-string entity)))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "reference not terminated by ';', starting at: '&"
- tmp
- (compute-coll-string coll)
- "'")))
- ))
- (#.state-dtd-!-attdef-decl-value6
- (let ((code (char-code ch)))
- (if* (eq #\; ch)
- then (add-to-coll coll (code-char char-code))
- (setf char-code 0)
- (setq state state-dtd-!-attdef-decl-value)
- elseif (<= (char-code #\0) code (char-code #\9))
- then (setf char-code (+ (* char-code 16) (- code (char-code #\0))))
- elseif (<= (char-code #\A) code (char-code #\F))
- then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\A))))
- elseif (<= (char-code #\a) code (char-code #\f))
- then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\a))))
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal hexidecimal character reference code, starting at: '"
- (compute-coll-string coll)
- "', calculated char code: "
- (format nil "~s" char-code)))
- )))
- (#.state-dtd-!-attdef-decl-value7
- (let ((code (char-code ch)))
- (if* (eq #\; ch)
- then (add-to-coll coll (code-char char-code))
- (setf char-code 0)
- (setq state reference-save-state)
- elseif (<= (char-code #\0) code (char-code #\9))
- then (setf char-code (+ (* char-code 10) (- code (char-code #\0))))
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal decimal character reference code, starting at: '"
- (compute-coll-string coll)
- "', calculated char code: "
- (format nil "~s" char-code)))
- )))
- (#.state-dtd-!-attdef-decl-type
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (or (xml-space-p ch) (eq #\> ch)) then
- (let ((token (compute-tag coll)))
- (when (and (not (eq :REQUIRED token))
- (not (eq :IMPLIED token))
- (not (eq :FIXED token)))
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (push token pending)
- (if* (eq :FIXED token) then
- (when (eq #\> ch)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (setf state state-dtd-!-attdef-decl-value2)
- elseif (eq #\> ch) then
- (setf contents-to-return
- (append contents-to-return (list (nreverse pending))))
- (return)
- else (setf contents-to-return
- (append contents-to-return (list (nreverse pending))))
- (setf pending (list nil))
- (setf state state-dtd-!-attdef)))
- (clear-coll coll)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#. state-dtd-!-attdef-decl-value2
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (or (eq #\' ch) (eq #\" ch)) then
- (setf value-delim ch)
- (setf state state-dtd-!-attdef-decl-value)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ATTLIST type spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-element-name)
- (un-next-char ch)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD characters, starting at: '<!ELEMENT "
- (compute-coll-string coll)
- "'"))))
- (#.state-dtd-!-element-name
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll)
- contents-to-return)
- (clear-coll coll)
- (setf state state-dtd-!-element-type)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT name: '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type
- (if* (eq #\( ch) then (setf state state-dtd-!-element-type-paren)
- elseif (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (un-next-char ch)
- (setf state state-dtd-!-element-type-token)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (un-next-char ch)
- (setf state state-dtd-!-element-type-paren-name)
- elseif (eq #\# ch) then
- (setf state state-dtd-!-element-type-paren-pcd)
- elseif (eq #\( ch) then
- (push nil pending)
- (setf state state-dtd-!-element-type-paren-choice-paren)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))))
- (#.state-dtd-!-element-type-paren2
- (if* (eq #\> ch) then
- ;; there only one name...
- (setf (first contents-to-return) (first (first contents-to-return)))
- (return)
- elseif (eq #\* ch) then
- (setf state state-dtd-!-element-type-paren-pcd5)
- (setf (first contents-to-return) (nreverse (first contents-to-return)))
- (if* (> (length (first contents-to-return)) 1) then
- (setf (first contents-to-return)
- (list (append (list :choice)
- (first contents-to-return))))
- elseif (listp (first (first contents-to-return))) then
- (setf (first contents-to-return)
- (first (first contents-to-return))))
- (push :* (first contents-to-return))
- elseif (eq #\? ch) then
- (setf state state-dtd-!-element-type-paren-pcd5)
- (setf (first contents-to-return) (nreverse (first contents-to-return)))
- (if* (> (length (first contents-to-return)) 1) then
- (setf (first contents-to-return)
- (list (append (list :choice)
- (first contents-to-return))))
- elseif (listp (first (first contents-to-return))) then
- (setf (first contents-to-return)
- (first (first contents-to-return))))
- (push :? (first contents-to-return))
- elseif (eq #\+ ch) then
- (setf state state-dtd-!-element-type-paren-pcd5)
- (setf (first contents-to-return) (nreverse (first contents-to-return)))
- (if* (> (length (first contents-to-return)) 1) then
- (setf (first contents-to-return)
- (list (append (list :choice)
- (first contents-to-return))))
- elseif (listp (first (first contents-to-return))) then
- (setf (first contents-to-return)
- (first (first contents-to-return))))
- (push :+ (first contents-to-return))
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (setf state state-dtd-!-element-type-paren-pcd5)
- (setf (first contents-to-return) (nreverse (first contents-to-return)))
- (when (> (length (first contents-to-return)) 1)
- (setf (first contents-to-return)
- (list (append (list :\choice)
- (first contents-to-return)))))
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-name
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-name2)
- elseif (eq #\? ch) then
- (push (compute-tag coll) (first pending))
- (setf (first pending)
- (list (push :? (first pending))))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-name2)
- elseif (eq #\* ch) then
- (push (compute-tag coll) (first pending))
- (setf (first pending)
- (list (push :* (first pending))))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-name2)
- elseif (eq #\+ ch) then
- (push (compute-tag coll) (first pending))
- (setf (first pending)
- (list (push :+ (first pending))))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-name2)
- elseif (eq #\) ch) then
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (if* (= (length pending) 1) then
- (push (first pending) contents-to-return)
- (setf state state-dtd-!-element-type-paren2)
- else ;; this is (xxx)
- (if* (second pending) then
- (push (first pending) (second pending))
- else (setf (second pending) (first pending)))
- (setf pending (rest pending))
- (setf state state-dtd-!-element-type-paren-choice-name3)
- )
- elseif (eq #\, ch) then
- (when (and (first pending) (not (eq :seq (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push (compute-tag coll) (first pending))
- (push :seq pending-type)
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-choice)
- elseif (eq #\| ch) then
- (when (and (first pending) (not (eq :choice (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push (compute-tag coll) (first pending))
- (push :choice pending-type)
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-choice)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-name2
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\| ch) then
- (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push :choice pending-type)
- (setf state state-dtd-!-element-type-paren-choice)
- elseif (eq #\, ch) then
- (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push :seq pending-type)
- (setf state state-dtd-!-element-type-paren-choice)
- elseif (eq #\) ch) then
- (if* (= (length pending) 1) then
- (push (list (first pending)) contents-to-return)
- (setf state state-dtd-!-element-type-paren2)
- else (setf pending (reverse (rest (reverse pending))))
- )
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
+ (case state
+ (#.state-dtdstart
+ (if* (and (eq #\] ch)
+ external (> include-count 0)) then
+ (setf state state-dtd-!-include3)
+ elseif (and (eq #\] ch) (not external)) then (return)
+ elseif (eq #\< ch) then (setf state state-tokenstart)
+ elseif (xml-space-p ch) then nil
+ elseif (eq #\% ch) then (external-param-reference tokenbuf coll external-callback)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-include3
+ (if* (eq #\] ch) then (setf state state-dtd-!-include4)
+ else
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD token, starting at: ']"
+ (compute-coll-string coll)
+ "'"))))
+ (#.state-dtd-!-include4
+ (if* (eq #\> ch) then (return)
+ else
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD token, starting at: ']]"
+ (compute-coll-string coll)
+ "'"))))
+ #+ignore
+ (#.state-dtd-pref
+ (if* (xml-name-start-char-p ch) then
+ (add-to-coll coll ch)
+ (setf state state-dtd-pref2)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD parameter reference name, starting at: '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-tokenstart
+ (if* (eq #\? ch) then (setf state state-dtd-?)
+ elseif (eq #\! ch) then (setf state state-dtd-!)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-?
+ (if* (xml-name-char-p ch)
+ then
+ (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else
+ (when (not (xml-space-p ch))
+ (xml-error (concatenate 'string
+ "expecting name following: '<?"
+ (compute-coll-string coll)
+ "' ; got: '" (string ch) "'"))
+ )
+ (when (= (collector-next coll) 0)
+ (xml-error "null <? token"))
+ (if* (and (= (collector-next coll) 3)
+ (or (eq (elt (collector-data coll) 0) #\X)
+ (eq (elt (collector-data coll) 0) #\x))
+ (or (eq (elt (collector-data coll) 1) #\M)
+ (eq (elt (collector-data coll) 1) #\m))
+ (or (eq (elt (collector-data coll) 2) #\L)
+ (eq (elt (collector-data coll) 2) #\l)))
+ then
+ (xml-error "<?xml not allowed in dtd")
+ else
+ (setq tag-to-return (compute-tag coll))
+ (setf state state-dtd-?-2))
+ (clear-coll coll)))
+ (#.state-dtd-?-2
+ (if* (xml-space-p ch)
+ then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (not (xml-char-p ch))
+ then (xml-error "XML is not well formed") ;; no test
+ else (add-to-coll coll ch)
+ (setf state state-dtd-?-3)))
+ (#.state-dtd-?-3
+ (if* (eq #\? ch)
+ then (setf state state-dtd-?-4)
+ elseif (not (xml-char-p ch))
+ then (xml-error "XML is not well formed") ;; no test
+ else (add-to-coll coll ch)))
+ (#.state-dtd-?-4
+ (if* (eq #\> ch)
+ then
+ (push (compute-coll-string coll) contents-to-return)
+ (clear-coll coll)
+ (return)
+ else (setf state state-dtd-?-3)
+ (add-to-coll coll #\?)
+ (add-to-coll coll ch)))
+ (#.state-dtd-!
+ (if* (eq #\- ch) then (setf state state-dtd-comment)
+ elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-token)
+ (un-next-char ch)
+ elseif (and (eq #\[ ch) external) then
+ (setf state state-dtd-!-cond)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<!"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-cond
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\I ch) then (setf state state-dtd-!-cond2)
+ else (error "this should not happen")
+ ))
+ (#.state-dtd-!-cond2
+ (if* (eq #\N ch) then (setf state state-dtd-!-include)
+ (setf check-count 2)
+ elseif (eq #\G ch) then (setf state state-dtd-!-ignore)
+ (setf check-count 2)
+ else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
+ ))
+ (#.state-dtd-!-ignore
+ (if* (and (eq check-count 5) (eq ch #\E)) then
+ (setf state state-dtd-!-ignore2)
+ elseif (eq ch (elt "IGNORE" check-count)) then
+ (incf check-count)
+ else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
+ ))
+ (#.state-dtd-!-ignore2
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\[ ch) then (setf state state-dtd-!-ignore3)
+ (incf ignore-count)
+ else (xml-error "'[' missing after '<![Ignore'")))
+ (#.state-dtd-!-ignore3
+ (if* (eq #\< ch) then (setf state state-dtd-!-ignore4)
+ elseif (eq #\] ch) then (setf state state-dtd-!-ignore5)))
+ (#.state-dtd-!-ignore4
+ (if* (eq #\! ch) then (setf state state-dtd-!-ignore6)
+ else (un-next-char ch)
+ (setf state state-dtd-!-ignore3)))
+ (#.state-dtd-!-ignore5
+ (if* (eq #\] ch) then (setf state state-dtd-!-ignore7)
+ else (un-next-char ch)
+ (setf state state-dtd-!-ignore3)))
+ (#.state-dtd-!-ignore6
+ (if* (eq #\[ ch) then (incf ignore-count)
+ (setf state state-dtd-!-ignore3)
+ else (un-next-char ch)
+ (setf state state-dtd-!-ignore3)))
+ (#.state-dtd-!-ignore7
+ (if* (eq #\> ch) then (decf ignore-count)
+ (when (= ignore-count 0) (return))
+ else (un-next-char ch)
+ (setf state state-dtd-!-ignore3)))
+ (#.state-dtd-!-include
+ (if* (and (eq check-count 6) (eq ch #\E)) then
+ (setf state state-dtd-!-include2)
+ elseif (eq ch (elt "INCLUD" check-count)) then
+ (incf check-count)
+ else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
+ ))
+ (#.state-dtd-!-include2
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\[ ch) then (return)
+ else (xml-error "'[' missing after '<![INCLUDE'")))
+ (#.state-dtd-comment
+ (if* (eq #\- ch)
+ then (setf state state-dtd-comment2)
+ (setf tag-to-return :comment)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal token following '<![-', starting at '<!-"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-comment2
+ (if* (eq #\- ch)
+ then (setf state state-dtd-comment3)
+ else (add-to-coll coll ch)))
+ (#.state-dtd-comment3
+ (if* (eq #\- ch)
+ then (setf state state-dtd-comment4)
+ else (setf state state-dtd-comment2)
+ (add-to-coll coll #\-) (add-to-coll coll ch)))
+ (#.state-dtd-comment4
+ (if* (eq #\> ch)
+ then (push (compute-coll-string coll) contents-to-return)
+ (clear-coll coll)
+ (return)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal token following '--' comment terminator, starting at '--"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-token
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (setf tag-to-return (compute-tag coll))
+ (clear-coll coll)
+ (if* (eq tag-to-return :ELEMENT) then (setf state state-dtd-!-element)
+ elseif (eq tag-to-return :ATTLIST) then
+ (setf state state-dtd-!-attlist)
+ elseif (eq tag-to-return :ENTITY) then
+ (setf entityp t)
+ (setf state state-dtd-!-entity)
+ elseif (eq tag-to-return :NOTATION) then
+ (setf state state-dtd-!-notation)
+ else
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<!"
+ (string tag-to-return)
+ "'")))
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<!"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-notation
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (add-to-coll coll ch)
+ (setf state state-dtd-!-notation2)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<!NOTATION "
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-notation2
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll) contents-to-return)
+ (clear-coll coll)
+ (setf state state-dtd-!-notation3)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!NOTATION name: "
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-notation3
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-char-p ch) then
+ (add-to-coll coll ch)
+ (setf state state-dtd-!-entity6)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!NOTATION spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-entity
+ (if* (eq #\% ch) then (push :param contents-to-return)
+ (setf pentityp t)
+ (setf state state-dtd-!-entity2)
+ elseif (xml-name-start-char-p ch) then
+ (add-to-coll coll ch)
+ (setf pending nil)
+ (setf state state-dtd-!-entity3)
+ elseif (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<!ENTITY "
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-entity2
+ (if* (xml-space-p ch) then (setf state state-dtd-!-entity7)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-entity3
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll) contents-to-return)
+ (setf contents-to-return
+ (nreverse contents-to-return))
+ (clear-coll coll)
+ (setf state state-dtd-!-entity4)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY name: "
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-entity4
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (or (eq #\' ch) (eq #\" ch)) then
+ (setf value-delim ch)
+ (setf state state-dtd-!-entity-value)
+ elseif (xml-name-start-char-p ch) then
+ (add-to-coll coll ch)
+ (setf state state-dtd-!-entity6)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY spec: '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-entity6
+ (if* (xml-name-char-p ch) ;; starting char already passed more restrictive test
+ then
+ (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else
+ (when (not (xml-space-p ch))
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error
+ (concatenate 'string
+ "illegal character in '"
+ (compute-coll-string coll)
+ "' in <! tag: " (string tag-to-return) " "
+ (string (first contents-to-return))
+ ))
+ )
+ (let ((token (compute-tag coll)))
+ (push token contents-to-return)
+ (clear-coll coll)
+ (if* (eq :SYSTEM token) then (setf state state-!-dtd-system)
+ elseif (eq :PUBLIC token) then (setf state state-!-dtd-public)
+ else (xml-error
+ (concatenate 'string
+ "expected 'SYSTEM' or 'PUBLIC' got '"
+ (string (first contents-to-return))
+ "' in <! tag: " (string tag-to-return) " "
+ (string (second contents-to-return))))
+ )
+ )))
+ (#.state-dtd-!-entity7
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (add-to-coll coll ch)
+ (setf state state-dtd-!-entity3)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY % name: "
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-!-dtd-public
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (or (eq #\" ch) (eq #\' ch)) then
+ (setf state state-!-dtd-public2)
+ (setf value-delim ch)
+ else (xml-error
+ (concatenate 'string
+ "expected quote or double-quote got: '"
+ (string ch)
+ "' in <! tag: " (string tag-to-return) " "
+ (string (second contents-to-return)) " "
+ (string (first contents-to-return))
+ ))))
+ (#.state-!-dtd-public2
+ (if* (eq value-delim ch) then
+ (push (setf public-string
+ (normalize-public-value
+ (compute-coll-string coll))) contents-to-return)
+ (clear-coll coll)
+ (setf state state-!-dtd-public3)
+ elseif (pub-id-char-p ch) then (add-to-coll coll ch)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error
+ (concatenate 'string
+ "illegal character in string: '"
+ (compute-coll-string coll) "'"))
+ ))
+ (#.state-!-dtd-public3
+ (if* (xml-space-p ch) then (setf state state-!-dtd-system)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (and (not entityp)
+ (eq #\> ch)) then
+ (setf state state-!-dtd-system)
+ (return)
+ else
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error
+ (concatenate 'string
+ "Expected space before: '"
+ (compute-coll-string coll) "'"))
+ ))
+ (#.state-!-dtd-system
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (or (eq #\" ch) (eq #\' ch)) then
+ (setf state state-!-dtd-system2)
+ (setf value-delim ch)
+ elseif (and (not entityp)
+ (eq #\> ch)) then (return)
+ else (xml-error
+ (concatenate 'string
+ "expected quote or double-quote got: '"
+ (string ch)
+ "' in <! tag: " (string tag-to-return) " "
+ (string (second contents-to-return)) " "
+ (string (first contents-to-return))
+ ))))
+ (#.state-!-dtd-system2
+ (when (not (xml-char-p ch))
+ (xml-error "XML is not well formed")) ;; not tested
+ (if* (eq value-delim ch) then
+ (let ((entity-symbol (first (last contents-to-return)))
+ (system-string (compute-coll-string coll)))
+ (if* pentityp then
+ (when (not (assoc entity-symbol (iostruct-parameter-entities tokenbuf)))
+ (setf (iostruct-parameter-entities tokenbuf)
+ (acons entity-symbol (list (parse-uri system-string)
+ tag-to-return
+ public-string)
+ (iostruct-parameter-entities tokenbuf)))
+ )
+ else
+ (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
+ (setf (iostruct-general-entities tokenbuf)
+ (acons entity-symbol (list (parse-uri system-string)
+ tag-to-return
+ public-string
+ )
+ (iostruct-general-entities tokenbuf)))
+ (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
+ (setf (iostruct-general-entities tokenbuf)
+ (acons entity-symbol (list (parse-uri system-string)
+ tag-to-return
+ public-string
+ )
+ (iostruct-general-entities tokenbuf))))
+ )
+ )
+ (push system-string contents-to-return))
+ (clear-coll coll)
+ (setf state state-!-dtd-system3)
+ else (add-to-coll coll ch)))
+ (#.state-!-dtd-system3
+ (if* (xml-space-p ch) then (setf state state-!-dtd-system4)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\> ch) then (return)
+ else
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY value for "
+ (string (first (nreverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-!-dtd-system4
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (and (not pentityp) (xml-name-start-char-p ch)) then
+ (add-to-coll coll ch)
+ (setf state state-!-dtd-system5)
+ elseif (eq #\> ch) then (return)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY value for "
+ (string (first (nreverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-!-dtd-system5
+ (if* (xml-name-char-p ch) then
+ (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (let ((token (compute-tag coll)))
+ (when (not (eq :NDATA token))
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY value for "
+ (string (first (nreverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ )
+ (clear-coll coll)
+ (push token contents-to-return)
+ (setf state state-!-dtd-system6))
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY value for "
+ (string (first (nreverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-!-dtd-system6
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (add-to-coll coll ch)
+ (setf state state-!-dtd-system7)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY value for "
+ (string (first (nreverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-!-dtd-system7
+ (if* (xml-name-char-p ch) then
+ (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll) contents-to-return)
+ (clear-coll coll)
+ (setf state state-dtd-!-entity5) ;; just looking for space, >
+ elseif (eq #\> ch) then
+ (push (compute-tag coll) contents-to-return)
+ (clear-coll coll)
+ (return)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY value for "
+ (string (first (nreverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-entity-value
+ (if* (eq ch value-delim) then
+ (let ((tmp (compute-coll-string coll)))
+ (when (> (length tmp) 0)
+ (when (null (first pending)) (setf pending (rest pending)))
+ (push tmp pending)))
+ (if* (> (length pending) 1) then
+ (push (nreverse pending) contents-to-return)
+ else (push (first pending) contents-to-return))
+ (setf pending (list nil))
+ (setf state state-dtd-!-entity5)
+ (clear-coll coll)
+ (if* pentityp then
+ (when (not (assoc (third contents-to-return)
+ (iostruct-parameter-entities tokenbuf)))
+ (setf (iostruct-parameter-entities tokenbuf)
+ (acons (third contents-to-return)
+ (first contents-to-return)
+ (iostruct-parameter-entities tokenbuf))))
+ else
+ (when (not (assoc (second contents-to-return)
+ (iostruct-general-entities tokenbuf)))
+ (setf (iostruct-general-entities tokenbuf)
+ (acons (second contents-to-return)
+ (first contents-to-return)
+ (iostruct-general-entities tokenbuf)))))
+ elseif (eq #\& ch) then
+ (setf reference-save-state state-dtd-!-entity-value)
+ (setf state state-dtd-!-attdef-decl-value3)
+ elseif (eq #\% ch) then
+ (setf prefp t)
+ (setf reference-save-state state-dtd-!-entity-value)
+ (setf state state-dtd-!-attdef-decl-value3)
+ elseif (xml-char-p ch)
+ then (add-to-coll coll ch)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ENTITY value for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-entity5
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\> ch) then (return)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD contents following <!ENTITY spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attlist
+ (if* (xml-name-start-char-p ch) then (setf state state-dtd-!-attlist-name)
+ (un-next-char ch)
+ elseif (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<!ATTLIST "
+ (compute-coll-string coll)
+ "'"))))
+ (#.state-dtd-!-attlist-name
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll *package*)
+ contents-to-return)
+ (clear-coll coll)
+ (setf state state-dtd-!-attdef)
+ elseif (eq #\> ch) then
+ (push (compute-tag coll *package*)
+ contents-to-return)
+ (clear-coll coll)
+ (return)
+ else (push (compute-tag coll)
+ contents-to-return)
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (un-next-char ch)
+ (setf state state-dtd-!-attdef-name)
+ elseif (eq #\> ch) then (return)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-name
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (setf (first pending) (compute-tag coll *package*))
+ (clear-coll coll)
+ (setf state state-dtd-!-attdef-type)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-type
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else (un-next-char ch)
+ ;; let next state do all other checking
+ (setf state state-dtd-!-attdef-type2)))
+ (#.state-dtd-!-attdef-type2
+ ;; can only be one of a few tokens, but wait until token built to check
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and (eq #\( ch) (= 0 (length (compute-coll-string coll)))) then
+ (push (list :enumeration) pending)
+ (setf state state-dtd-!-attdef-notation2)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (let ((token (compute-tag coll)))
+ (when (and (not (eq :CDATA token))
+ (not (eq :ID token))
+ (not (eq :IDREF token))
+ (not (eq :IDREFS token))
+ (not (eq :ENTITY token))
+ (not (eq :ENTITIES token))
+ (not (eq :NMTOKEN token))
+ (not (eq :NMTOKENS token))
+ (not (eq :NOTATION token)))
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (if* (eq token :NOTATION) then
+ (push (list token) pending)
+ (setf state state-dtd-!-attdef-notation)
+ else
+ (push token pending)
+ (setf state state-dtd-!-attdef-decl))
+ )
+ (clear-coll coll)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-notation
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\( ch) then (setf state state-dtd-!-attdef-notation2)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-notation2
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (setf state state-dtd-!-attdef-notation3)
+ (add-to-coll coll ch)
+ elseif (and (xml-name-char-p ch) (listp (first pending))
+ (eq :enumeration (first (reverse (first pending))))) then
+ (setf state state-dtd-!-attdef-notation3)
+ (add-to-coll coll ch)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-notation3
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (setf state state-dtd-!-attdef-notation4)
+ elseif (eq #\| ch) then
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (setf state state-dtd-!-attdef-notation2)
+ elseif (eq #\) ch) then
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (setf (first pending) (nreverse (first pending)))
+ ;;(setf state state-dtd-!-attdef-decl)
+ (setf state state-dtd-!-attdef-notation5)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-notation5
+ (if* (xml-space-p ch) then (setf state state-dtd-!-attdef-decl)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error
+ (concatenate 'string
+ "Expected space before: '"
+ (compute-coll-string coll) "'"))))
+ (#.state-dtd-!-attdef-notation4
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-char-p ch) then (add-to-coll coll ch)
+ (setf state state-dtd-!-attdef-notation3)
+ elseif (eq #\| ch) then (setf state state-dtd-!-attdef-notation2)
+ elseif (eq #\) ch) then (setf state state-dtd-!-attdef-decl)
+ (setf (first pending) (nreverse (first pending)))
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-decl
+ (if* (eq #\# ch) then
+ (setf state state-dtd-!-attdef-decl-type)
+ elseif (or (eq #\' ch) (eq #\" ch)) then
+ (setf value-delim ch)
+ (setf state state-dtd-!-attdef-decl-value)
+ elseif (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-decl-value
+ (if* (eq ch value-delim) then
+ #-ignore
+ (push (first (parse-default-value (list (compute-coll-string coll))
+ tokenbuf external-callback))
+ pending)
+ #+ignore
+ (push (compute-coll-string coll) pending)
+ (setf contents-to-return
+ (append contents-to-return
+ (if* entityp then
+ (nreverse pending)
+ else (list (nreverse pending)))))
+ (setf pending (list nil))
+ (setf state state-dtd-!-attdef)
+ (clear-coll coll)
+ elseif (eq #\& ch) then (setf state state-dtd-!-attdef-decl-value3)
+ (setf reference-save-state state-dtd-!-attdef-decl-value)
+ elseif (and (xml-char-p ch) (not (eq #\< ch)))
+ then (add-to-coll coll ch)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-decl-value3
+ (if* (and (not prefp) (eq #\# ch))
+ then (setf state state-dtd-!-attdef-decl-value4)
+ elseif (xml-name-start-char-p ch)
+ then (setf state state-dtd-!-attdef-decl-value5)
+ (when (not prefp) (add-to-coll coll #\&))
+ (un-next-char ch)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal reference name, starting at: '&"
+ (compute-coll-string coll)
+ "'"))))
+ (#.state-dtd-!-attdef-decl-value4
+ (if* (eq #\x ch)
+ then (setf state state-dtd-!-attdef-decl-value6)
+ elseif (<= (char-code #\0) (char-code ch) (char-code #\9))
+ then (setf state state-dtd-!-attdef-decl-value7)
+ (un-next-char ch)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal character reference code, starting at: '&#"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-attdef-decl-value5
+ (if* (xml-name-char-p ch)
+ then (add-to-coll entity ch)
+ (when (not prefp) (add-to-coll coll ch))
+ elseif (eq #\; ch)
+ then
+ (if* (not prefp) then (add-to-coll coll ch)
+ elseif (not external) then
+ (xml-error
+ (concatenate 'string
+ "internal dtd subset cannot reference parameter entity within a token; entity: "
+ (compute-coll-string entity)))
+ else
+ (let* ((entity-symbol (compute-tag entity))
+ (p-value
+ (assoc entity-symbol (iostruct-parameter-entities tokenbuf))))
+ (clear-coll entity)
+ (if* (and (iostruct-do-entity tokenbuf)
+ (setf p-value
+ (assoc entity-symbol
+ (iostruct-parameter-entities tokenbuf)))) then
+ (setf p-value (rest p-value))
+ (when (member entity-symbol (iostruct-entity-names tokenbuf))
+ (xml-error (concatenate 'string
+ "entity:"
+ (string entity-symbol)
+ " in recursive reference")))
+ (push entity-symbol (iostruct-entity-names tokenbuf))
+ (if* (stringp p-value) then
+ (dotimes (i (length p-value))
+ (add-to-coll coll (schar p-value i)))
+ elseif p-value then
+ (if* (null external-callback) then
+ (setf (iostruct-do-entity tokenbuf) nil)
+ else
+ (let ((count 0) (string "<?xml ") last-ch
+ save-ch save-unget
+ (tmp-count 0)
+ (entity-stream
+ (apply external-callback p-value)))
+ (when entity-stream
+ (let ((tmp-buf (get-tokenbuf)))
+ (setf (tokenbuf-stream tmp-buf)
+ entity-stream)
+ (setf save-unget
+ (iostruct-unget-char tokenbuf))
+ (setf (iostruct-unget-char tokenbuf) nil)
+ (unicode-check entity-stream tokenbuf)
+ (when (iostruct-unget-char tokenbuf)
+ (setf save-ch (first (iostruct-unget-char tokenbuf))))
+ (setf (iostruct-unget-char tokenbuf) save-unget)
+ (loop
+ (let ((cch
+ (if* save-ch
+ then
+ (let ((s2 save-ch))
+ (setf save-ch nil)
+ s2)
+ else
+ (next-char
+ tmp-buf
+ (iostruct-read-sequence-func
+ tokenbuf)))))
+ (when (null cch) (return))
+ (when *debug-dtd*
+ (format t "dtd-char: ~s~%" cch))
+ (if* (< count 0) then
+ (if* (and (eq last-ch #\?)
+ (eq cch #\>)) then
+ (setf count 6)
+ else (setf last-ch cch))
+ elseif (< count 6) then
+ (when (and (= count 5)
+ (xml-space-p cch))
+ (setf cch #\space))
+ (if* (not (eq cch
+ (schar string count)
+ )) then
+ (loop
+ (when (= tmp-count count)
+ (return))
+ (add-to-coll coll
+ (schar string
+ tmp-count))
+ (incf tmp-count))
+ (add-to-coll coll cch)
+ (setf count 10)
+ else (incf count))
+ elseif (= count 6) then
+ (dotimes (i 6)
+ (add-to-coll coll (schar string i)))
+ (setf count 10)
+ else (add-to-coll coll cch))))
+ (setf (iostruct-entity-names tokenbuf)
+ (rest (iostruct-entity-names tokenbuf)))
+ (close entity-stream)
+ (put-back-tokenbuf tmp-buf)))))
+ )
+ (setf state state-dtdstart)
+ else nil
+ )))
+ (setf state reference-save-state)
+ else (let ((tmp (compute-coll-string entity)))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "reference not terminated by ';', starting at: '&"
+ tmp
+ (compute-coll-string coll)
+ "'")))
+ ))
+ (#.state-dtd-!-attdef-decl-value6
+ (let ((code (char-code ch)))
+ (if* (eq #\; ch)
+ then (add-to-coll coll (code-char char-code))
+ (setf char-code 0)
+ (setq state state-dtd-!-attdef-decl-value)
+ elseif (<= (char-code #\0) code (char-code #\9))
+ then (setf char-code (+ (* char-code 16) (- code (char-code #\0))))
+ elseif (<= (char-code #\A) code (char-code #\F))
+ then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\A))))
+ elseif (<= (char-code #\a) code (char-code #\f))
+ then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\a))))
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal hexidecimal character reference code, starting at: '"
+ (compute-coll-string coll)
+ "', calculated char code: "
+ (format nil "~s" char-code)))
+ )))
+ (#.state-dtd-!-attdef-decl-value7
+ (let ((code (char-code ch)))
+ (if* (eq #\; ch)
+ then (add-to-coll coll (code-char char-code))
+ (setf char-code 0)
+ (setq state reference-save-state)
+ elseif (<= (char-code #\0) code (char-code #\9))
+ then (setf char-code (+ (* char-code 10) (- code (char-code #\0))))
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal decimal character reference code, starting at: '"
+ (compute-coll-string coll)
+ "', calculated char code: "
+ (format nil "~s" char-code)))
+ )))
+ (#.state-dtd-!-attdef-decl-type
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (or (xml-space-p ch) (eq #\> ch)) then
+ (let ((token (compute-tag coll)))
+ (when (and (not (eq :REQUIRED token))
+ (not (eq :IMPLIED token))
+ (not (eq :FIXED token)))
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (push token pending)
+ (if* (eq :FIXED token) then
+ (when (eq #\> ch)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (setf state state-dtd-!-attdef-decl-value2)
+ elseif (eq #\> ch) then
+ (setf contents-to-return
+ (append contents-to-return (list (nreverse pending))))
+ (return)
+ else (setf contents-to-return
+ (append contents-to-return (list (nreverse pending))))
+ (setf pending (list nil))
+ (setf state state-dtd-!-attdef)))
+ (clear-coll coll)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#. state-dtd-!-attdef-decl-value2
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (or (eq #\' ch) (eq #\" ch)) then
+ (setf value-delim ch)
+ (setf state state-dtd-!-attdef-decl-value)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ATTLIST type spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-element-name)
+ (un-next-char ch)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD characters, starting at: '<!ELEMENT "
+ (compute-coll-string coll)
+ "'"))))
+ (#.state-dtd-!-element-name
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll)
+ contents-to-return)
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT name: '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type
+ (if* (eq #\( ch) then (setf state state-dtd-!-element-type-paren)
+ elseif (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (un-next-char ch)
+ (setf state state-dtd-!-element-type-token)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (un-next-char ch)
+ (setf state state-dtd-!-element-type-paren-name)
+ elseif (eq #\# ch) then
+ (setf state state-dtd-!-element-type-paren-pcd)
+ elseif (eq #\( ch) then
+ (push nil pending)
+ (setf state state-dtd-!-element-type-paren-choice-paren)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))))
+ (#.state-dtd-!-element-type-paren2
+ (if* (eq #\> ch) then
+ ;; there only one name...
+ (setf (first contents-to-return) (first (first contents-to-return)))
+ (return)
+ elseif (eq #\* ch) then
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ (setf (first contents-to-return) (nreverse (first contents-to-return)))
+ (if* (> (length (first contents-to-return)) 1) then
+ (setf (first contents-to-return)
+ (list (append (list :choice)
+ (first contents-to-return))))
+ elseif (listp (first (first contents-to-return))) then
+ (setf (first contents-to-return)
+ (first (first contents-to-return))))
+ (push :* (first contents-to-return))
+ elseif (eq #\? ch) then
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ (setf (first contents-to-return) (nreverse (first contents-to-return)))
+ (if* (> (length (first contents-to-return)) 1) then
+ (setf (first contents-to-return)
+ (list (append (list :choice)
+ (first contents-to-return))))
+ elseif (listp (first (first contents-to-return))) then
+ (setf (first contents-to-return)
+ (first (first contents-to-return))))
+ (push :? (first contents-to-return))
+ elseif (eq #\+ ch) then
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ (setf (first contents-to-return) (nreverse (first contents-to-return)))
+ (if* (> (length (first contents-to-return)) 1) then
+ (setf (first contents-to-return)
+ (list (append (list :choice)
+ (first contents-to-return))))
+ elseif (listp (first (first contents-to-return))) then
+ (setf (first contents-to-return)
+ (first (first contents-to-return))))
+ (push :+ (first contents-to-return))
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ (setf (first contents-to-return) (nreverse (first contents-to-return)))
+ (when (> (length (first contents-to-return)) 1)
+ (setf (first contents-to-return)
+ (list (append (list :\choice)
+ (first contents-to-return)))))
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-name
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-name2)
+ elseif (eq #\? ch) then
+ (push (compute-tag coll) (first pending))
+ (setf (first pending)
+ (list (push :? (first pending))))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-name2)
+ elseif (eq #\* ch) then
+ (push (compute-tag coll) (first pending))
+ (setf (first pending)
+ (list (push :* (first pending))))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-name2)
+ elseif (eq #\+ ch) then
+ (push (compute-tag coll) (first pending))
+ (setf (first pending)
+ (list (push :+ (first pending))))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-name2)
+ elseif (eq #\) ch) then
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (if* (= (length pending) 1) then
+ (push (first pending) contents-to-return)
+ (setf state state-dtd-!-element-type-paren2)
+ else ;; this is (xxx)
+ (if* (second pending) then
+ (push (first pending) (second pending))
+ else (setf (second pending) (first pending)))
+ (setf pending (rest pending))
+ (setf state state-dtd-!-element-type-paren-choice-name3)
+ )
+ elseif (eq #\, ch) then
+ (when (and (first pending) (not (eq :seq (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push (compute-tag coll) (first pending))
+ (push :seq pending-type)
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-choice)
+ elseif (eq #\| ch) then
+ (when (and (first pending) (not (eq :choice (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push (compute-tag coll) (first pending))
+ (push :choice pending-type)
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-choice)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-name2
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\| ch) then
+ (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push :choice pending-type)
+ (setf state state-dtd-!-element-type-paren-choice)
+ elseif (eq #\, ch) then
+ (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push :seq pending-type)
+ (setf state state-dtd-!-element-type-paren-choice)
+ elseif (eq #\) ch) then
+ (if* (= (length pending) 1) then
+ (push (list (first pending)) contents-to-return)
+ (setf state state-dtd-!-element-type-paren2)
+ else (setf pending (reverse (rest (reverse pending))))
+ )
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
- (#.state-dtd-!-element-type-paren-choice-paren
- (if* (xml-name-start-char-p ch) then
- (setf state state-dtd-!-element-type-paren-name)
- (un-next-char ch)
- elseif (eq #\( ch) then (push nil pending)
- elseif (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-choice-name
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-choice-name2)
- elseif (eq #\? ch) then
- (push (list :? (compute-tag coll)) (first pending))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-choice-name2)
- elseif (eq #\* ch) then
- (push (list :* (compute-tag coll)) (first pending))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-choice-name2)
- elseif (eq #\+ ch) then
- (push (list :+ (compute-tag coll)) (first pending))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-choice-name2)
- elseif (eq #\) ch) then
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (if* (= (length pending) 1) then
- (setf (first pending) (nreverse (first pending)))
- (if* (> (length (first pending)) 1) then
- (push (first pending-type) (first pending))
- (setf pending-type (rest pending-type))
- else (setf (first pending) (first (first pending))))
- (push (first pending) contents-to-return)
- (setf state state-dtd-!-element-type-paren3)
- else (setf (first pending) (nreverse (first pending)))
- (push (first pending-type) (first pending))
- (setf pending-type (rest pending-type))
- (if* (second pending) then
- (push (first pending) (second pending))
- else (setf (second pending)
- ;; (list (first pending)) ;2001-03-22
- (first pending) ;2001-03-22
- ))
- (setf pending (rest pending))
- (setf state state-dtd-!-element-type-paren-choice-name3)
- )
- elseif (eq #\, ch) then
- (when (and (first pending) (not (eq :seq (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (push :seq pending-type)
- (setf state state-dtd-!-element-type-paren-choice)
- elseif (eq #\| ch) then
- (when (and (first pending) (not (eq :choice (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push (compute-tag coll) (first pending))
- (clear-coll coll)
- (push :choice pending-type)
- (setf state state-dtd-!-element-type-paren-choice)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-choice-name2
- (if* (eq #\| ch)
- ;; begin changes 2001-03-22
- then (setf state state-dtd-!-element-type-paren-choice)
- (push :choice pending-type)
- elseif (eq #\, ch)
- then (setf state state-dtd-!-element-type-paren-choice)
- (push :seq pending-type)
- ;; end changes 2001-03-22
- elseif (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\) ch) then
- (if* (= (length pending) 1) then
- (setf (first pending) (nreverse (first pending)))
- (if* (> (length (first pending)) 1) then
- (push (first pending-type) (first pending))
- (setf pending-type (rest pending-type))
- else (setf (first pending) (first (first pending))))
- (push (first pending) contents-to-return)
- (setf state state-dtd-!-element-type-paren3)
- else (setf (first pending) (nreverse (first pending)))
- (push (first pending-type) (first pending))
- (setf pending-type (rest pending-type))
- (if* (second pending) then
- (push (first pending) (second pending))
- else (setf (second pending) (list (first pending))))
- (setf state state-dtd-!-element-type-paren-choice-name3)
- )
- (setf pending (rest pending))
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-choice-name3
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\? ch) then
- (setf (first pending) (list :? (first pending)))
- (setf state state-dtd-!-element-type-paren-choice-name2)
- elseif (eq #\* ch) then
- (setf (first pending) (list :* (first pending)))
- (setf state state-dtd-!-element-type-paren-choice-name2)
- elseif (eq #\+ ch) then
- (setf (first pending) (list :+ (first pending)))
- (setf state state-dtd-!-element-type-paren-choice-name2)
- elseif (eq #\) ch) then
- (if* (= (length pending) 1) then
- (setf (first pending) (nreverse (first pending)))
- (if* (> (length (first pending)) 1) then
- (push (first pending-type) (first pending))
- (setf pending-type (rest pending-type))
- else (setf (first pending) (first (first pending))))
- (push (first pending) contents-to-return)
- (setf pending (rest pending))
- (setf state state-dtd-!-element-type-paren3)
- else (setf (first pending) (nreverse (first pending)))
- (if* (> (length (first pending)) 1) then
- (push (first pending-type) (first pending))
- (setf pending-type (rest pending-type))
- else (setf (first pending) (first (first pending))))
- (if* (second pending) then
- (push (first pending) (second pending))
- else (setf (second pending) (list (first pending))))
- (setf pending (rest pending))
- (setf state state-dtd-!-element-type-paren-choice)
- )
- elseif (eq #\, ch) then
- (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push :seq pending-type)
- (setf state state-dtd-!-element-type-paren-choice)
- elseif (eq #\| ch) then
- (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
- (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal '|' and ',' mix starting at '"
- (compute-coll-string coll)
- "'")))
- (push :choice pending-type)
- (setf state state-dtd-!-element-type-paren-choice)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren3
- (if* (eq #\+ ch) then
- (setf (first contents-to-return)
- (append (list :+) (list (first contents-to-return))))
- (setf state state-dtd-!-element-type-paren-pcd5)
- elseif (eq #\? ch) then
- (setf (first contents-to-return)
- (append (list :?) (list (first contents-to-return))))
- (setf state state-dtd-!-element-type-paren-pcd5)
- elseif (eq #\* ch) then
- (setf (first contents-to-return)
- (append (list :*) (list (first contents-to-return))))
- (setf state state-dtd-!-element-type-paren-pcd5)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (setf state state-dtd-!-element-type-paren-pcd5)
- elseif (eq #\> ch) then (return)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (let ((token (compute-tag coll)))
- (when (not (eq token :PCDATA))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (clear-coll coll)
- (push token contents-to-return))
- (setf state state-dtd-!-element-type-paren-pcd2)
- elseif (eq #\| ch) then
- (let ((token (compute-tag coll)))
- (when (not (eq token :PCDATA))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (push token contents-to-return))
- (clear-coll coll)
- (setf state state-dtd-!-element-type-paren-pcd3)
- elseif (eq #\) ch) then
- (let ((token (compute-tag coll)))
- (when (not (eq token :PCDATA))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (push token contents-to-return))
- (setf state state-dtd-!-element-type-paren-pcd4)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd2
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\) ch) then
- (setf state state-dtd-!-element-type-paren-pcd4)
- elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd3
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-name-start-char-p ch) then
- (un-next-char ch)
- (setf state state-dtd-!-element-type-paren-pcd7)
- else (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd4
- (if* (xml-space-p ch) then
- (setf state state-dtd-!-element-type-paren-pcd6)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\* ch) then
- (setf (first contents-to-return) '(:* :PCDATA))
- (setf state state-dtd-!-element-type-paren-pcd5)
- elseif (eq #\> ch) then (return)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD contents following <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd5
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\> ch) then (return)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD contents following <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd6
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\> ch) then (return)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD contents following <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd7
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (setf state state-dtd-!-element-type-paren-pcd8)
- (let ((token (compute-tag coll)))
- (clear-coll coll)
- (if* (listp (first contents-to-return)) then
- (push token (first contents-to-return))
- else (setf (first contents-to-return)
- (list token (first contents-to-return)))))
- elseif (eq #\) ch) then
- (setf state state-dtd-!-element-type-paren-pcd9)
- (let ((token (compute-tag coll)))
- (clear-coll coll)
- (if* (listp (first contents-to-return)) then
- (push token (first contents-to-return))
- else (setf (first contents-to-return)
- (list token (first contents-to-return)))))
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD contents in <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd8
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
- elseif (eq #\) ch) then (setf state state-dtd-!-element-type-paren-pcd9)
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD contents in <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-paren-pcd9
- (if* (eq #\* ch) then (setf state state-dtd-!-element-type-paren-pcd5)
- (setf (first contents-to-return) (nreverse (first contents-to-return)))
- (when (> (length (first contents-to-return)) 1)
- (setf (first contents-to-return)
- (list (append (list :choice)
- (first contents-to-return)))))
- (push :* (first contents-to-return))
- else (clear-coll coll)
- (dotimes (i 15)
- (add-to-coll coll ch)
- (setq ch (get-next-char tokenbuf))
- (if* (null ch)
- then (return)))
- (xml-error (concatenate 'string
- "illegal DTD contents in <!ELEMENT content spec for "
- (string (first (reverse contents-to-return)))
- ": '"
- (compute-coll-string coll)
- "'"))
- ))
- (#.state-dtd-!-element-type-token
- (if* (xml-name-char-p ch) then (add-to-coll coll ch)
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (xml-space-p ch) then
- (let ((token (compute-tag coll)))
- (when (not (or (eq token :EMPTY) (eq token :ANY)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (push token contents-to-return)
- (setf state state-dtd-!-element-type-end))
- elseif (eq #\> ch) then
- (let ((token (compute-tag coll)))
- (when (not (or (eq token :EMPTY) (eq token :ANY)))
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'")))
- (push token contents-to-return)
- (return))
- else (add-to-coll coll ch)
- (xml-error (concatenate 'string
- "illegal DTD <!ELEMENT content spec for "
- (string (first contents-to-return))
- ": '"
- (compute-coll-string coll)
- "'"))
- )
- )
- (#.state-dtd-!-element-type-end
- (if* (xml-space-p ch) then nil
- elseif (and external (eq #\% ch)) then
- (external-param-reference tokenbuf coll external-callback)
- elseif (eq #\> ch) then (return)
- else (xml-error (concatenate 'string
- "expected '>', got '"
- (string ch)
- "' in DTD <! ELEMENT "
- (string (first contents-to-return))
- " for "
- (string (second contents-to-return))))
- ))
- (t
- (error "need to support dtd state:~s" state))))
+ (#.state-dtd-!-element-type-paren-choice-paren
+ (if* (xml-name-start-char-p ch) then
+ (setf state state-dtd-!-element-type-paren-name)
+ (un-next-char ch)
+ elseif (eq #\( ch) then (push nil pending)
+ elseif (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-choice-name
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-choice-name2)
+ elseif (eq #\? ch) then
+ (push (list :? (compute-tag coll)) (first pending))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-choice-name2)
+ elseif (eq #\* ch) then
+ (push (list :* (compute-tag coll)) (first pending))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-choice-name2)
+ elseif (eq #\+ ch) then
+ (push (list :+ (compute-tag coll)) (first pending))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-choice-name2)
+ elseif (eq #\) ch) then
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (if* (= (length pending) 1) then
+ (setf (first pending) (nreverse (first pending)))
+ (if* (> (length (first pending)) 1) then
+ (push (first pending-type) (first pending))
+ (setf pending-type (rest pending-type))
+ else (setf (first pending) (first (first pending))))
+ (push (first pending) contents-to-return)
+ (setf state state-dtd-!-element-type-paren3)
+ else (setf (first pending) (nreverse (first pending)))
+ (push (first pending-type) (first pending))
+ (setf pending-type (rest pending-type))
+ (if* (second pending) then
+ (push (first pending) (second pending))
+ else (setf (second pending)
+ ;; (list (first pending)) ;2001-03-22
+ (first pending) ;2001-03-22
+ ))
+ (setf pending (rest pending))
+ (setf state state-dtd-!-element-type-paren-choice-name3)
+ )
+ elseif (eq #\, ch) then
+ (when (and (first pending) (not (eq :seq (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (push :seq pending-type)
+ (setf state state-dtd-!-element-type-paren-choice)
+ elseif (eq #\| ch) then
+ (when (and (first pending) (not (eq :choice (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push (compute-tag coll) (first pending))
+ (clear-coll coll)
+ (push :choice pending-type)
+ (setf state state-dtd-!-element-type-paren-choice)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-choice-name2
+ (if* (eq #\| ch)
+ ;; begin changes 2001-03-22
+ then (setf state state-dtd-!-element-type-paren-choice)
+ (push :choice pending-type)
+ elseif (eq #\, ch)
+ then (setf state state-dtd-!-element-type-paren-choice)
+ (push :seq pending-type)
+ ;; end changes 2001-03-22
+ elseif (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\) ch) then
+ (if* (= (length pending) 1) then
+ (setf (first pending) (nreverse (first pending)))
+ (if* (> (length (first pending)) 1) then
+ (push (first pending-type) (first pending))
+ (setf pending-type (rest pending-type))
+ else (setf (first pending) (first (first pending))))
+ (push (first pending) contents-to-return)
+ (setf state state-dtd-!-element-type-paren3)
+ else (setf (first pending) (nreverse (first pending)))
+ (push (first pending-type) (first pending))
+ (setf pending-type (rest pending-type))
+ (if* (second pending) then
+ (push (first pending) (second pending))
+ else (setf (second pending) (list (first pending))))
+ (setf state state-dtd-!-element-type-paren-choice-name3)
+ )
+ (setf pending (rest pending))
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-choice-name3
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\? ch) then
+ (setf (first pending) (list :? (first pending)))
+ (setf state state-dtd-!-element-type-paren-choice-name2)
+ elseif (eq #\* ch) then
+ (setf (first pending) (list :* (first pending)))
+ (setf state state-dtd-!-element-type-paren-choice-name2)
+ elseif (eq #\+ ch) then
+ (setf (first pending) (list :+ (first pending)))
+ (setf state state-dtd-!-element-type-paren-choice-name2)
+ elseif (eq #\) ch) then
+ (if* (= (length pending) 1) then
+ (setf (first pending) (nreverse (first pending)))
+ (if* (> (length (first pending)) 1) then
+ (push (first pending-type) (first pending))
+ (setf pending-type (rest pending-type))
+ else (setf (first pending) (first (first pending))))
+ (push (first pending) contents-to-return)
+ (setf pending (rest pending))
+ (setf state state-dtd-!-element-type-paren3)
+ else (setf (first pending) (nreverse (first pending)))
+ (if* (> (length (first pending)) 1) then
+ (push (first pending-type) (first pending))
+ (setf pending-type (rest pending-type))
+ else (setf (first pending) (first (first pending))))
+ (if* (second pending) then
+ (push (first pending) (second pending))
+ else (setf (second pending) (list (first pending))))
+ (setf pending (rest pending))
+ (setf state state-dtd-!-element-type-paren-choice)
+ )
+ elseif (eq #\, ch) then
+ (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push :seq pending-type)
+ (setf state state-dtd-!-element-type-paren-choice)
+ elseif (eq #\| ch) then
+ (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
+ (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal '|' and ',' mix starting at '"
+ (compute-coll-string coll)
+ "'")))
+ (push :choice pending-type)
+ (setf state state-dtd-!-element-type-paren-choice)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren3
+ (if* (eq #\+ ch) then
+ (setf (first contents-to-return)
+ (append (list :+) (list (first contents-to-return))))
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ elseif (eq #\? ch) then
+ (setf (first contents-to-return)
+ (append (list :?) (list (first contents-to-return))))
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ elseif (eq #\* ch) then
+ (setf (first contents-to-return)
+ (append (list :*) (list (first contents-to-return))))
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ elseif (eq #\> ch) then (return)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (let ((token (compute-tag coll)))
+ (when (not (eq token :PCDATA))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (clear-coll coll)
+ (push token contents-to-return))
+ (setf state state-dtd-!-element-type-paren-pcd2)
+ elseif (eq #\| ch) then
+ (let ((token (compute-tag coll)))
+ (when (not (eq token :PCDATA))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (push token contents-to-return))
+ (clear-coll coll)
+ (setf state state-dtd-!-element-type-paren-pcd3)
+ elseif (eq #\) ch) then
+ (let ((token (compute-tag coll)))
+ (when (not (eq token :PCDATA))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (push token contents-to-return))
+ (setf state state-dtd-!-element-type-paren-pcd4)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd2
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\) ch) then
+ (setf state state-dtd-!-element-type-paren-pcd4)
+ elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd3
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-name-start-char-p ch) then
+ (un-next-char ch)
+ (setf state state-dtd-!-element-type-paren-pcd7)
+ else (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd4
+ (if* (xml-space-p ch) then
+ (setf state state-dtd-!-element-type-paren-pcd6)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\* ch) then
+ (setf (first contents-to-return) '(:* :PCDATA))
+ (setf state state-dtd-!-element-type-paren-pcd5)
+ elseif (eq #\> ch) then (return)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD contents following <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd5
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\> ch) then (return)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD contents following <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd6
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\> ch) then (return)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD contents following <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd7
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (setf state state-dtd-!-element-type-paren-pcd8)
+ (let ((token (compute-tag coll)))
+ (clear-coll coll)
+ (if* (listp (first contents-to-return)) then
+ (push token (first contents-to-return))
+ else (setf (first contents-to-return)
+ (list token (first contents-to-return)))))
+ elseif (eq #\) ch) then
+ (setf state state-dtd-!-element-type-paren-pcd9)
+ (let ((token (compute-tag coll)))
+ (clear-coll coll)
+ (if* (listp (first contents-to-return)) then
+ (push token (first contents-to-return))
+ else (setf (first contents-to-return)
+ (list token (first contents-to-return)))))
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD contents in <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd8
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
+ elseif (eq #\) ch) then (setf state state-dtd-!-element-type-paren-pcd9)
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD contents in <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-paren-pcd9
+ (if* (eq #\* ch) then (setf state state-dtd-!-element-type-paren-pcd5)
+ (setf (first contents-to-return) (nreverse (first contents-to-return)))
+ (when (> (length (first contents-to-return)) 1)
+ (setf (first contents-to-return)
+ (list (append (list :choice)
+ (first contents-to-return)))))
+ (push :* (first contents-to-return))
+ else (clear-coll coll)
+ (dotimes (i 15)
+ (add-to-coll coll ch)
+ (setq ch (get-next-char tokenbuf))
+ (if* (null ch)
+ then (return)))
+ (xml-error (concatenate 'string
+ "illegal DTD contents in <!ELEMENT content spec for "
+ (string (first (reverse contents-to-return)))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ ))
+ (#.state-dtd-!-element-type-token
+ (if* (xml-name-char-p ch) then (add-to-coll coll ch)
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (xml-space-p ch) then
+ (let ((token (compute-tag coll)))
+ (when (not (or (eq token :EMPTY) (eq token :ANY)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (push token contents-to-return)
+ (setf state state-dtd-!-element-type-end))
+ elseif (eq #\> ch) then
+ (let ((token (compute-tag coll)))
+ (when (not (or (eq token :EMPTY) (eq token :ANY)))
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'")))
+ (push token contents-to-return)
+ (return))
+ else (add-to-coll coll ch)
+ (xml-error (concatenate 'string
+ "illegal DTD <!ELEMENT content spec for "
+ (string (first contents-to-return))
+ ": '"
+ (compute-coll-string coll)
+ "'"))
+ )
+ )
+ (#.state-dtd-!-element-type-end
+ (if* (xml-space-p ch) then nil
+ elseif (and external (eq #\% ch)) then
+ (external-param-reference tokenbuf coll external-callback)
+ elseif (eq #\> ch) then (return)
+ else (xml-error (concatenate 'string
+ "expected '>', got '"
+ (string ch)
+ "' in DTD <! ELEMENT "
+ (string (first contents-to-return))
+ " for "
+ (string (second contents-to-return))))
+ ))
+ (t
+ (error "need to support dtd state:~s" state))))