Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Assorted bug fixes. #3

Closed
wants to merge 7 commits into from
Closed

Assorted bug fixes. #3

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
452edbf
Fix memory leak in klacks
dmitryvk Nov 16, 2011
cd4a047
remove runtime dependency on asdf
hanshuebner Aug 1, 2013
583463b
Allegro CL modern mode fixes
hanshuebner Aug 1, 2011
92fcb4e
Fix DTD embedding.
Ferada Feb 15, 2015
9c4c384
Complain if UTF-16 documents try to switch to UTF-8.
ruricolist Aug 29, 2014
20ad8be
Stop reversing the attribute list.
ruricolist Jun 18, 2015
508dc7e
Avoid duplicate internal subsets.
ruricolist Sep 27, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 5 additions & 1 deletion klacks/klacks-impl.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -311,6 +311,7 @@
(with-source (source current-key current-values current-attributes)
(setf current-key :end-element)
(setf current-attributes nil)
(pop (base-stack *ctx*))
(validate-end-element *ctx* (third current-values))
cont))

Expand All @@ -319,12 +320,15 @@
current-key current-values current-attributes namespace-stack
current-namespace-declarations)
(let ((values* current-values)
(new-b current-namespace-declarations))
(new-b current-namespace-declarations)
(ns-stack namespace-stack))
(setf current-attributes nil)
(push n-b namespace-stack)
(let ((finish
(lambda ()
(pop (base-stack *ctx*))
(setf current-namespace-declarations new-b)
(setf namespace-stack ns-stack)
(klacks/element-3 source input values* cont))))
(klacks/content source input finish)))))

Expand Down
2 changes: 1 addition & 1 deletion klacks/klacks.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -99,7 +99,7 @@
(sax:start-cdata handler)
(sax:characters handler a)
(sax:end-cdata handler))
(T
(t
(sax:characters handler a))))
(:processing-instruction
(sax:processing-instruction handler a b))
Expand Down
8 changes: 5 additions & 3 deletions xml/catalog.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -226,9 +226,11 @@
(warn "ignoring catalog error: ~A" c))))

(defparameter *catalog-dtd*
(let* ((cxml
(slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))
(dtd (merge-pathnames "catalog.dtd" cxml)))
(let* ((load-truename #.(or *compile-file-truename* *load-truename*))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not sure I like this. What's wrong with having the path by asdf-relative?

(dtd (make-pathname :name "catalog"
:directory (butlast (pathname-directory load-truename))
:type "dtd"
:defaults load-truename)))
(with-open-file (s dtd :element-type '(unsigned-byte 8))
(let ((bytes
(make-array (file-length s) :element-type '(unsigned-byte 8))))
Expand Down
24 changes: 12 additions & 12 deletions xml/xml-name-rune-p.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -162,20 +162,20 @@
(setf (aref r i) 1))))) )

`(progn
(DEFINLINE NAME-RUNE-P (RUNE)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

can we have a separate commit for things that are just case changes?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Aren't the case changes all in the "Allegro CL modern mode fixes" commit?

(SETF RUNE (RUNE-CODE RUNE))
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))
(definline name-rune-p (rune)
(setf rune (rune-code rune))
(locally (declare (optimize (safety 0) (speed 3))
(type fixnum rune))
(AND (<= 0 RUNE ,+max+)
(= 1 (SBIT ',(predicate-to-bv #'name-rune-p)
RUNE)))))
(DEFINLINE NAME-START-RUNE-P (RUNE)
(SETF RUNE (RUNE-CODE RUNE))
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))
(and (<= 0 rune ,+max+)
(= 1 (sbit ',(predicate-to-bv #'name-rune-p)
rune)))))
(definline name-start-rune-p (rune)
(setf rune (rune-code rune))
(locally (declare (optimize (safety 0) (speed 3))
(type fixnum rune))
(AND (<= 0 RUNE ,+MAX+)
(= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p)
RUNE)))))
(and (<= 0 rune ,+max+)
(= 1 (sbit ',(predicate-to-bv #'name-start-rune-p)
rune)))))
(definline valid-name-p (rod)
(and (plusp (length rod))
(name-start-rune-p (elt rod 0))
Expand Down
50 changes: 27 additions & 23 deletions xml/xml-parse.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2506,10 +2506,14 @@

(defun setup-encoding (input xml-header)
(when (xml-header-encoding xml-header)
(let ((enc (find-encoding (xml-header-encoding xml-header))))
(cond (enc
(setf (xstream-encoding (car (zstream-input-stack input)))
enc))
(let ((enc (find-encoding (xml-header-encoding xml-header)))
(xstream (car (zstream-input-stack input))))
(cond ((eql enc :utf-8)
(let ((old (xstream-encoding xstream)))
(unless (eql old :utf-8)
(with-simple-restart (continue "Stick with ~a" old)
(wf-error input "Header says UTF-8, but BOM says ~a." old)))))
(enc (setf (xstream-encoding xstream) enc))
(t
(warn "There is no such encoding: ~S." (xml-header-encoding xml-header)))))))

Expand Down Expand Up @@ -2604,12 +2608,15 @@
(let ((xi2 (xstream-open-extid effective-extid)))
(with-zstream (zi2 :input-stack (list xi2))
(ensure-dtd)
(unless (ignore-errors (have-internal-subset (handler *ctx*)))
(sax:start-internal-subset (handler *ctx*)))
(p/ext-subset zi2)
(when (and fresh-dtd-p
*cache-all-dtds*
*validate*
(not (standalone-p *ctx*)))
(setf (getdtd sysid *dtd-cache*) (dtd *ctx*)))))))))
(setf (getdtd sysid *dtd-cache*) (dtd *ctx*)))
(sax:end-internal-subset (handler *ctx*))))))))
(sax:end-dtd (handler *ctx*))
(let ((dtd (dtd *ctx*)))
(sax:entity-resolver
Expand Down Expand Up @@ -3563,20 +3570,20 @@
(let ((input-var (gensym))
(collect (gensym))
(c (gensym)))
`(LET ((,input-var ,input))
(MULTIPLE-VALUE-BIND (,res ,res-start ,res-end)
(WITH-RUNE-COLLECTOR/RAW (,collect)
(LOOP
(LET ((,c (PEEK-RUNE ,input-var)))
(COND ((EQ ,c :EOF)
`(let ((,input-var ,input))
(multiple-value-bind (,res ,res-start ,res-end)
(with-rune-collector/raw (,collect)
(loop
(let ((,c (peek-rune ,input-var)))
(cond ((eq ,c :eof)
;; xxx error message
(RETURN))
((FUNCALL ,predicate ,c)
(RETURN))
(return))
((funcall ,predicate ,c)
(return))
(t
(,collect ,c)
(CONSUME-RUNE ,input-var))))))
(LOCALLY
(consume-rune ,input-var))))))
(locally
,@body)))))

(defun read-name-token (input)
Expand Down Expand Up @@ -3833,13 +3840,10 @@
(defun build-attribute-list (attr-alist)
;; fixme: if there is a reason this function reverses attribute order,
;; it should be documented.
(let (attributes)
(dolist (pair attr-alist)
(push (sax:make-attribute :qname (car pair)
:value (cdr pair)
:specified-p t)
attributes))
attributes))
(loop for (qname . value) in attr-alist
collect (sax:make-attribute :qname qname
:value value
:specified-p t)))

(defun check-attribute-uniqueness (attributes)
;; 5.3 Uniqueness of Attributes
Expand Down