X-Git-Url: http://git.kpe.io/?p=xmlutils.git;a=blobdiff_plain;f=pxml1.cl;h=3ddd101e6f7f98a99b5bde225fe8748730757983;hp=ce9fa65946ecfeeb3f3887815f5ba9ab4ec4a77a;hb=HEAD;hpb=96edd80309cfaea1949768cd4b3a5f7e0dc203d5 diff --git a/pxml1.cl b/pxml1.cl index ce9fa65..3ddd101 100644 --- a/pxml1.cl +++ b/pxml1.cl @@ -33,22 +33,22 @@ (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)) @@ -85,21 +85,21 @@ (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 @@ -113,57 +113,57 @@ (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))) @@ -174,7 +174,7 @@ ;; 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) @@ -187,82 +187,82 @@ (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) @@ -275,90 +275,90 @@ #+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)) @@ -367,11 +367,11 @@ (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) @@ -379,71 +379,71 @@ (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)))