(declare (optimize (speed 3) (safety 1)))
(without-scheduling
(do ((cols *collectors* (cdr cols)))
- ((null cols)
- ; toss it away
- nil)
+ ((null cols)
+ ; toss it away
+ nil)
(if* (null (car cols))
- then (setf (car cols) col)
- (return)))))
+ then (setf (car cols) col)
+ (return)))))
(defun pub-id-char-p (char)
(declare (optimize (speed 3) (safety 1)))
(let ((code (char-code char)))
(or (= #x20 code) (= #xD code) (= #xA code)
- (<= (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 '( #\- #\' #\( #\) #\+ #\, #\. #\/ #\: #\= #\?
+ #\; #\! #\* #\# #\@ #\$ #\_ #\%)))))
(defparameter *keyword-package* (find-package :keyword))
(let (buf)
(without-scheduling
(do* ((bufs *tokenbufs* (cdr bufs))
- (this (car bufs) (car bufs)))
- ((null bufs))
- (if* this
- then (setf (car bufs) nil)
- (setq buf this)
- (return))))
+ (this (car bufs) (car bufs)))
+ ((null bufs))
+ (if* this
+ then (setf (car bufs) nil)
+ (setq buf this)
+ (return))))
(if* buf
then (setf (tokenbuf-cur buf) 0)
- (setf (tokenbuf-max buf) 0)
- (setf (tokenbuf-stream buf) nil)
- buf
+ (setf (tokenbuf-max buf) 0)
+ (setf (tokenbuf-stream buf) nil)
+ buf
else (make-tokenbuf
- :cur 0
- :max 0
- :data (make-array 1024 :element-type 'character)))))
+ :cur 0
+ :max 0
+ :data (make-array 1024 :element-type 'character)))))
(defstruct collector
next ; next index to set
(if* (not ns-to-package)
then (excl::intern* (collector-data coll) (collector-next coll) package)
else
- (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)))
+ ))
+ ))
(defun compute-coll-string (coll)
(declare (optimize (speed 3) (safety 1)))
;; return the string that's in the collection
(let ((str (make-string (collector-next coll)))
- (from (collector-data coll)))
+ (from (collector-data coll)))
(dotimes (i (collector-next coll))
(setf (schar str i) (schar from i)))
;; increase the size of the data portion of the collector and then
;; add the given char at the end
(let* ((odata (collector-data coll))
- (ndata (make-string (* 2 (length odata)))))
+ (ndata (make-string (* 2 (length odata)))))
(dotimes (i (length odata))
(setf (schar ndata i) (schar odata i)))
(setf (collector-data coll) ndata)
(declare (optimize (speed 3) (safety 1)))
(without-scheduling
(do ((bufs *tokenbufs* (cdr bufs)))
- ((null bufs)
- ; toss it away
- nil)
+ ((null bufs)
+ ; toss it away
+ nil)
(if* (null (car bufs))
- then (setf (car bufs) buf)
- (return)))))
+ then (setf (car bufs) buf)
+ (return)))))
(defun get-collector ()
(declare (optimize (speed 3) (safety 1)))
(let (col)
(without-scheduling
(do* ((cols *collectors* (cdr cols))
- (this (car cols) (car cols)))
- ((null cols))
- (if* this
- then (setf (car cols) nil)
- (setq col this)
- (return))))
+ (this (car cols) (car cols)))
+ ((null cols))
+ (if* this
+ then (setf (car cols) nil)
+ (setq col this)
+ (return))))
(if* col
then (setf (collector-next col) 0)
- col
+ col
else (make-collector
- :next 0
- :max 100
- :data (make-string 100)))))
+ :next 0
+ :max 100
+ :data (make-string 100)))))
(defmacro next-char (tokenbuf read-sequence-func)
`(let ((cur (tokenbuf-cur ,tokenbuf))
- (tb (tokenbuf-data ,tokenbuf)))
+ (tb (tokenbuf-data ,tokenbuf)))
(if* (>= cur (tokenbuf-max ,tokenbuf))
- 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)))
(if* cur
- then (prog1
- (let ((cc (schar tb cur)))
- (if (and (tokenbuf-stream ,tokenbuf) (eq #\return cc)) #\newline cc))
- (setf (tokenbuf-cur ,tokenbuf) (1+ cur))))))
+ then (prog1
+ (let ((cc (schar tb cur)))
+ (if (and (tokenbuf-stream ,tokenbuf) (eq #\return cc)) #\newline cc))
+ (setf (tokenbuf-cur ,tokenbuf) (1+ cur))))))
(defun get-next-char (iostruct)
(declare (optimize (speed 3) (safety 1)))
(let* (from-stream (tmp-char
- (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))))))
(if* (and from-stream (eq tmp-char #\return)) then #\newline else tmp-char)))
(defun unicode-check (p tokenbuf)
#+allegro
(let ((format (ignore-errors (excl:sniff-for-unicode p))))
(if* (eq format (find-external-format :unicode))
- then
- (setf (stream-external-format p) format)
- else
- (setf (stream-external-format p) (find-external-format :utf8))))
+ then
+ (setf (stream-external-format p) format)
+ else
+ (setf (stream-external-format p) (find-external-format :utf8))))
#-allegro
(let* ((c (read-char p nil)) c2
- (c-code (if c (char-code c) nil)))
+ (c-code (if c (char-code c) nil)))
(if* (eq #xFF c-code) then
- (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
+ )))))
(defun add-default-values (val attlist-data)
(declare (ignorable old-coll) (optimize (speed 3) (safety 1)))
(if* (symbolp val)
then
- (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)
+ )
else
- ;; 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))
+ ))
(defun normalize-public-value (public-value)
(setf public-value (string-trim '(#\space) public-value))
(when (= count stop) (return public-value))
(setf cch (schar public-value count))
(if* (and (eq cch #\space) (eq last-ch #\space)) then
- (setf public-value
- (remove #\space public-value :start count :count 1))
- (decf stop)
- else (incf count)
- (setf last-ch cch)))))
+ (setf public-value
+ (remove #\space public-value :start count :count 1))
+ (decf stop)
+ else (incf count)
+ (setf last-ch cch)))))
(defun normalize-attrib-value (attrib-value &optional first-pass)
(when first-pass
(let ((count 0) (stop (length attrib-value)) (last-ch nil) cch)
(loop
- (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
- (remove #\space attrib-value :start count :count 1))
- (decf stop)
- else (incf count)
- (setf last-ch cch)))))
+ (setf attrib-value
+ (remove #\space attrib-value :start count :count 1))
+ (decf stop)
+ else (incf count)
+ (setf last-ch cch)))))
(defun check-xmldecl (val tokenbuf)
(declare (ignorable old-coll) (optimize (speed 3) (safety 1)))
(when (not (and (symbolp (second val)) (string= "version" (symbol-name (second val)))))
(xml-error "XML declaration tag does not include correct 'version' attribute"))
(when (and (fourth val)
- (or (not (symbolp (fourth val)))
- (and (not (string= "standalone" (symbol-name (fourth val))))
- (not (string= "encoding" (symbol-name (fourth val)))))))
+ (or (not (symbolp (fourth val)))
+ (and (not (string= "standalone" (symbol-name (fourth val))))
+ (not (string= "encoding" (symbol-name (fourth val)))))))
(xml-error "XML declaration tag does not include correct 'encoding' or 'standalone' attribute"))
(when (and (fourth val) (string= "standalone" (symbol-name (fourth val))))
(if* (equal (fifth val) "yes") then
- (setf (iostruct-standalonep tokenbuf) t)
+ (setf (iostruct-standalonep tokenbuf) t)
elseif (not (equal (fifth val) "no")) then
- (xml-error "XML declaration tag does not include correct 'standalone' attribute value")))
+ (xml-error "XML declaration tag does not include correct 'standalone' attribute value")))
(dotimes (i (length (third val)))
(let ((c (schar (third val) i)))
(when (and (not (alpha-char-p c))
- (not (digit-char-p c))
- (not (member c '(#\. #\_ #\- #\:)))
- )
- (xml-error "XML declaration tag does not include correct 'version' attribute value"))))
+ (not (digit-char-p c))
+ (not (member c '(#\. #\_ #\- #\:)))
+ )
+ (xml-error "XML declaration tag does not include correct 'version' attribute value"))))
(if* (and (fourth val) (eql :encoding (fourth val)))
then (dotimes (i (length (fifth val)))
- (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
#+allegro
- (if* (tokenbuf-stream (iostruct-tokenbuf tokenbuf))
- then (setf (stream-external-format
- (tokenbuf-stream (iostruct-tokenbuf tokenbuf)))
- (find-external-format (fifth val))))
-
-
- ))
+ (if* (tokenbuf-stream (iostruct-tokenbuf tokenbuf))
+ then (setf (stream-external-format
+ (tokenbuf-stream (iostruct-tokenbuf tokenbuf)))
+ (find-external-format (fifth val))))
+
+
+ ))
(defun xml-error (text)
(declare (optimize (speed 3) (safety 1)))
projects / xmlutils.git / blobdiff