- (<= (char-code #\a) code (char-code #\z))
- (<= (char-code #\A) code (char-code #\Z))
- (<= (char-code #\0) code (char-code #\9))
- (member char '( #\- #\' #\( #\) #\+ #\, #\. #\/ #\: #\= #\?
- #\; #\! #\* #\# #\@ #\$ #\_ #\%)))))
+ (<= (char-code #\a) code (char-code #\z))
+ (<= (char-code #\A) code (char-code #\Z))
+ (<= (char-code #\0) code (char-code #\9))
+ (member char '( #\- #\' #\( #\) #\+ #\, #\. #\/ #\: #\= #\?
+ #\; #\! #\* #\# #\@ #\$ #\_ #\%)))))
- (let (new-package (data (collector-data coll)))
- (if* (and (eq (schar data 0) #\x)
- (eq (schar data 1) #\m)
- (eq (schar data 2) #\l)
- (eq (schar data 3) #\n)
- (eq (schar data 4) #\s)
- (or (eq (schar data 5) #\:)
- (= (collector-next coll) 5)))
- then ;; putting xmlns: in :none namespace
- (setf new-package (assoc :none ns-to-package))
- (when new-package (setf package (rest new-package)))
- (excl::intern* (collector-data coll) (collector-next coll) package)
- else
- (let ((colon-index -1)
- (data (collector-data coll)))
- (dotimes (i (collector-next coll))
- (when (eq (schar data i) #\:)
- (setf colon-index i)
- (return)))
- (if* (> colon-index -1) then
- (let ((string1 (make-string colon-index))
- new-package string2)
- (dotimes (i colon-index)
- (setf (schar string1 i) (schar data i)))
- (setf new-package (assoc string1 ns-to-package :test 'string=))
- (if* new-package
- then
- (setf string2 (make-string (- (collector-next coll)
- (+ 1 colon-index))))
- (dotimes (i (- (collector-next coll)
- (+ 1 colon-index)))
- (setf (schar string2 i)
- (schar data (+ colon-index 1 i))))
- (excl::intern string2 (rest new-package))
- else
- (excl::intern* (collector-data coll)
- (collector-next coll) package)))
- else
- (let ((new-package (assoc :none ns-to-package)))
- (when new-package
- (setf package (rest new-package))))
- (excl::intern* (collector-data coll)
- (collector-next coll) package)))
- ))
- ))
+ (let (new-package (data (collector-data coll)))
+ (if* (and (eq (schar data 0) #\x)
+ (eq (schar data 1) #\m)
+ (eq (schar data 2) #\l)
+ (eq (schar data 3) #\n)
+ (eq (schar data 4) #\s)
+ (or (eq (schar data 5) #\:)
+ (= (collector-next coll) 5)))
+ then ;; putting xmlns: in :none namespace
+ (setf new-package (assoc :none ns-to-package))
+ (when new-package (setf package (rest new-package)))
+ (excl::intern* (collector-data coll) (collector-next coll) package)
+ else
+ (let ((colon-index -1)
+ (data (collector-data coll)))
+ (dotimes (i (collector-next coll))
+ (when (eq (schar data i) #\:)
+ (setf colon-index i)
+ (return)))
+ (if* (> colon-index -1) then
+ (let ((string1 (make-string colon-index))
+ new-package string2)
+ (dotimes (i colon-index)
+ (setf (schar string1 i) (schar data i)))
+ (setf new-package (assoc string1 ns-to-package :test 'string=))
+ (if* new-package
+ then
+ (setf string2 (make-string (- (collector-next coll)
+ (+ 1 colon-index))))
+ (dotimes (i (- (collector-next coll)
+ (+ 1 colon-index)))
+ (setf (schar string2 i)
+ (schar data (+ colon-index 1 i))))
+ (excl::intern string2 (rest new-package))
+ else
+ (excl::intern* (collector-data coll)
+ (collector-next coll) package)))
+ else
+ (let ((new-package (assoc :none ns-to-package)))
+ (when new-package
+ (setf package (rest new-package))))
+ (excl::intern* (collector-data coll)
+ (collector-next coll) package)))
+ ))
+ ))
- then ;; fill buffer
- (if* (or (not (tokenbuf-stream ,tokenbuf))
- (zerop (setf (tokenbuf-max ,tokenbuf)
- (if* ,read-sequence-func
- then (funcall ,read-sequence-func tb
- (tokenbuf-stream ,tokenbuf))
- else (read-sequence tb (tokenbuf-stream ,tokenbuf))))))
- then (setq cur nil) ;; eof
- else (setq cur 0)))
+ then ;; fill buffer
+ (if* (or (not (tokenbuf-stream ,tokenbuf))
+ (zerop (setf (tokenbuf-max ,tokenbuf)
+ (if* ,read-sequence-func
+ then (funcall ,read-sequence-func tb
+ (tokenbuf-stream ,tokenbuf))
+ else (read-sequence tb (tokenbuf-stream ,tokenbuf))))))
+ then (setq cur nil) ;; eof
+ else (setq cur 0)))
- (let (char)
- (if* (iostruct-unget-char iostruct) then
- ;; from-stream is used to do input CR/LF normalization
- (setf from-stream t)
- (setf char (first (iostruct-unget-char iostruct)))
- (setf (iostruct-unget-char iostruct) (rest (iostruct-unget-char iostruct)))
- char
- elseif (iostruct-entity-bufs iostruct) then
- (let (entity-buf)
- (loop
- (setf entity-buf (first (iostruct-entity-bufs iostruct)))
- (if* (streamp (tokenbuf-stream entity-buf))
- then (setf from-stream t)
- else (setf from-stream nil))
- (setf char (next-char entity-buf (iostruct-read-sequence-func iostruct)))
- (when char (return))
- (when (streamp (tokenbuf-stream entity-buf))
- (close (tokenbuf-stream entity-buf))
- (put-back-tokenbuf entity-buf))
- (setf (iostruct-entity-bufs iostruct) (rest (iostruct-entity-bufs iostruct)))
- (setf (iostruct-entity-names iostruct) (rest (iostruct-entity-names iostruct)))
- (when (not (iostruct-entity-bufs iostruct)) (return))))
- (if* char then char
- else (next-char (iostruct-tokenbuf iostruct)
- (iostruct-read-sequence-func iostruct)))
- else (setf from-stream t)
- (next-char (iostruct-tokenbuf iostruct)
- (iostruct-read-sequence-func iostruct))))))
+ (let (char)
+ (if* (iostruct-unget-char iostruct) then
+ ;; from-stream is used to do input CR/LF normalization
+ (setf from-stream t)
+ (setf char (first (iostruct-unget-char iostruct)))
+ (setf (iostruct-unget-char iostruct) (rest (iostruct-unget-char iostruct)))
+ char
+ elseif (iostruct-entity-bufs iostruct) then
+ (let (entity-buf)
+ (loop
+ (setf entity-buf (first (iostruct-entity-bufs iostruct)))
+ (if* (streamp (tokenbuf-stream entity-buf))
+ then (setf from-stream t)
+ else (setf from-stream nil))
+ (setf char (next-char entity-buf (iostruct-read-sequence-func iostruct)))
+ (when char (return))
+ (when (streamp (tokenbuf-stream entity-buf))
+ (close (tokenbuf-stream entity-buf))
+ (put-back-tokenbuf entity-buf))
+ (setf (iostruct-entity-bufs iostruct) (rest (iostruct-entity-bufs iostruct)))
+ (setf (iostruct-entity-names iostruct) (rest (iostruct-entity-names iostruct)))
+ (when (not (iostruct-entity-bufs iostruct)) (return))))
+ (if* char then char
+ else (next-char (iostruct-tokenbuf iostruct)
+ (iostruct-read-sequence-func iostruct)))
+ else (setf from-stream t)
+ (next-char (iostruct-tokenbuf iostruct)
+ (iostruct-read-sequence-func iostruct))))))
- (setf c2 (read-char p nil))
- (setf c-code (if c (char-code c2) nil))
- (if* (eq #xFE c-code) then
- (format t "set unicode~%")
- (setf (stream-external-format p)
- (find-external-format
- #+allegro :unicode
- #-allegro :fat-little))
- else
- (xml-error "stream has incomplete Unicode marker"))
- else (setf (stream-external-format p)
- (find-external-format :utf8))
- (when c
- (push c (iostruct-unget-char tokenbuf))
- #+ignore (unread-char c p) ;; bug when there is single ^M in file
- )))))
+ (setf c2 (read-char p nil))
+ (setf c-code (if c (char-code c2) nil))
+ (if* (eq #xFE c-code) then
+ (format t "set unicode~%")
+ (setf (stream-external-format p)
+ (find-external-format
+ #+allegro :unicode
+ #-allegro :fat-little))
+ else
+ (xml-error "stream has incomplete Unicode marker"))
+ else (setf (stream-external-format p)
+ (find-external-format :utf8))
+ (when c
+ (push c (iostruct-unget-char tokenbuf))
+ #+ignore (unread-char c p) ;; bug when there is single ^M in file
+ )))))
- (let* ((tag-defaults (assoc val attlist-data)) defaults)
- (dolist (def (rest tag-defaults))
- (if* (stringp (third def)) then
- (push (first def) defaults)
- (push (if (eq (second def) :CDATA) (third def)
- (normalize-attrib-value (third def))) defaults)
- elseif (and (eq (third def) :FIXED) (stringp (fourth def))) then
- (push (first def) defaults)
- (push (if (eq (second def) :CDATA) (fourth def)
- (normalize-attrib-value (fourth def))) defaults)
- ))
- (if* defaults then
- (setf val (append (list val) (nreverse defaults)))
- else val)
- )
+ (let* ((tag-defaults (assoc val attlist-data)) defaults)
+ (dolist (def (rest tag-defaults))
+ (if* (stringp (third def)) then
+ (push (first def) defaults)
+ (push (if (eq (second def) :CDATA) (third def)
+ (normalize-attrib-value (third def))) defaults)
+ elseif (and (eq (third def) :FIXED) (stringp (fourth def))) then
+ (push (first def) defaults)
+ (push (if (eq (second def) :CDATA) (fourth def)
+ (normalize-attrib-value (fourth def))) defaults)
+ ))
+ (if* defaults then
+ (setf val (append (list val) (nreverse defaults)))
+ else val)
+ )
- ;; first make sure there are no errors in given list
- (let ((pairs (rest val)))
- (loop
- (when (null pairs) (return))
- (let ((this-one (first pairs)))
- (setf pairs (rest (rest pairs)))
- (when (member this-one pairs)
- (xml-error (concatenate 'string "Entity: "
- (string (first val))
- " has multiple "
- (string this-one)
- " attribute values"))))))
- (let ((tag-defaults (assoc (first val) attlist-data)) defaults)
- (dolist (def (rest tag-defaults))
- (let ((old (member (first def) (rest val))))
- (if* (not old) then
- (if* (stringp (third def)) then
- (push (first def) defaults)
- (push (third def) defaults)
- elseif (and (eq (third def) :FIXED) (stringp (fourth def))) then
- (push (first def) defaults)
- (push (fourth def) defaults))
- else
- (push (first old) defaults)
- (push (second old) defaults))))
- (if* defaults then
- ;; now look for attributes in original list that weren't in dtd
- (let ((tmp-val (rest val)) att att-val)
- (loop
- (when (null tmp-val) (return))
- (setf att (first tmp-val))
- (setf att-val (second tmp-val))
- (setf tmp-val (rest (rest tmp-val)))
- (when (not (member att defaults))
- (push att defaults)
- (push att-val defaults))))
- (setf val (append (list (first val)) (nreverse defaults)))
- else val))
- ))
+ ;; first make sure there are no errors in given list
+ (let ((pairs (rest val)))
+ (loop
+ (when (null pairs) (return))
+ (let ((this-one (first pairs)))
+ (setf pairs (rest (rest pairs)))
+ (when (member this-one pairs)
+ (xml-error (concatenate 'string "Entity: "
+ (string (first val))
+ " has multiple "
+ (string this-one)
+ " attribute values"))))))
+ (let ((tag-defaults (assoc (first val) attlist-data)) defaults)
+ (dolist (def (rest tag-defaults))
+ (let ((old (member (first def) (rest val))))
+ (if* (not old) then
+ (if* (stringp (third def)) then
+ (push (first def) defaults)
+ (push (third def) defaults)
+ elseif (and (eq (third def) :FIXED) (stringp (fourth def))) then
+ (push (first def) defaults)
+ (push (fourth def) defaults))
+ else
+ (push (first old) defaults)
+ (push (second old) defaults))))
+ (if* defaults then
+ ;; now look for attributes in original list that weren't in dtd
+ (let ((tmp-val (rest val)) att att-val)
+ (loop
+ (when (null tmp-val) (return))
+ (setf att (first tmp-val))
+ (setf att-val (second tmp-val))
+ (setf tmp-val (rest (rest tmp-val)))
+ (when (not (member att defaults))
+ (push att defaults)
+ (push att-val defaults))))
+ (setf val (append (list (first val)) (nreverse defaults)))
+ else val))
+ ))
- (when (= count stop) (return))
- (setf cch (schar attrib-value count))
- (if* (or (eq cch #\return) (eq cch #\tab)) then (setf (schar attrib-value count) #\space)
- elseif (and (eq cch #\newline) (not (eq last-ch #\return))) then
- (setf (schar attrib-value count) #\space)
- elseif (and (eq cch #\newline) (eq last-ch #\return)) then
- (setf attrib-value
- (remove #\space attrib-value :start count :count 1))
- (decf stop))
- (incf count)
- (setf last-ch cch))))
+ (when (= count stop) (return))
+ (setf cch (schar attrib-value count))
+ (if* (or (eq cch #\return) (eq cch #\tab)) then (setf (schar attrib-value count) #\space)
+ elseif (and (eq cch #\newline) (not (eq last-ch #\return))) then
+ (setf (schar attrib-value count) #\space)
+ elseif (and (eq cch #\newline) (eq last-ch #\return)) then
+ (setf attrib-value
+ (remove #\space attrib-value :start count :count 1))
+ (decf stop))
+ (incf count)
+ (setf last-ch cch))))
(setf attrib-value (string-trim '(#\space) attrib-value))
(let ((count 0) (stop (length attrib-value)) (last-ch nil) cch)
(loop
(when (= count stop) (return attrib-value))
(setf cch (schar attrib-value count))
(if* (and (eq cch #\space) (eq last-ch #\space)) then
(setf attrib-value (string-trim '(#\space) attrib-value))
(let ((count 0) (stop (length attrib-value)) (last-ch nil) cch)
(loop
(when (= count stop) (return attrib-value))
(setf cch (schar attrib-value count))
(if* (and (eq cch #\space) (eq last-ch #\space)) then
- (let ((c (schar (fifth val) i)))
- (when (and (not (alpha-char-p c))
- (if* (> i 0) then
- (and (not (digit-char-p c))
- (not (member c '(#\. #\_ #\-))))
- else t))
- (xml-error "XML declaration tag does not include correct 'encoding' attribute value"))))
- ;; jkf 3/26/02
- ;; if we have a stream we're reading from set its external-format
- ;; to the encoding
- ;; note - tokenbuf is really an iostruct, not a tokenbuf
+ (let ((c (schar (fifth val) i)))
+ (when (and (not (alpha-char-p c))
+ (if* (> i 0) then
+ (and (not (digit-char-p c))
+ (not (member c '(#\. #\_ #\-))))
+ else t))
+ (xml-error "XML declaration tag does not include correct 'encoding' attribute value"))))
+ ;; jkf 3/26/02
+ ;; if we have a stream we're reading from set its external-format
+ ;; to the encoding
+ ;; note - tokenbuf is really an iostruct, not a tokenbuf