From d48e55084636a84d1b54f1f7370fa98c55f3ec6e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 14 May 2004 22:57:29 +0000 Subject: [PATCH] 0.8.10.23: Fixed bug 322: ... DEFSTRUCT :TYPE LIST type predicates now work on improper lists. ... Trivially reorganized code to make said predicates traverse the list only once. ... MORE TESTS, of course. --- BUGS | 7 +------ NEWS | 2 ++ src/code/defstruct.lisp | 15 ++++++++------- tests/defstruct.impure.lisp | 21 +++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 33 insertions(+), 14 deletions(-) diff --git a/BUGS b/BUGS index 16b98ce..15c55b5 100644 --- a/BUGS +++ b/BUGS @@ -1457,12 +1457,7 @@ WORKAROUND: (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s))) 322: "DEFSTRUCT :TYPE LIST predicate and improper lists" - reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP - test suite. - (defstruct (a (:type list) (:initial-offset 5) :named)) - (defstruct (b (:type list) (:initial-offset 2) :named (:include a))) - (b-p (list* nil nil nil nil nil 'foo73 nil 'tail)) - gives an error in sbcl-0.8.10 + (fixed in sbcl-0.8.10.23) 323: "REPLACE, BIT-BASH and large strings" The transform for REPLACE on simple-base-strings uses BIT-BASH, which diff --git a/NEWS b/NEWS index 4cc9d18..b2579e9 100644 --- a/NEWS +++ b/NEWS @@ -2398,6 +2398,8 @@ changes in sbcl-0.8.10 relative to sbcl-0.8.9: to Bruno Haible) changes in sbcl-0.8.11 relative to sbcl-0.8.10: + * fixed bug 322: DEFSTRUCT :TYPE LIST type predicates now handle + improper lists correctly. (reported by Bruno Haible) * fixed bug 313: source-transform for was erroneously applied to a call of a value of a variable with name . (reported by Antonio Menezes Leitao) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 391aae1..0660f8e 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -424,15 +424,16 @@ (and (typep ,argname ',ltype) ,(cond ((subtypep ltype 'list) - `(consp (nthcdr ,name-index (the ,ltype ,argname)))) + `(do ((head (the ,ltype ,argname) (cdr head)) + (i 0 (1+ i))) + ((or (not (consp head)) (= i ,name-index)) + (and (consp head) (eq ',name (car head)))))) ((subtypep ltype 'vector) - `(= (length (the ,ltype ,argname)) - ,(dd-length defstruct))) + `(and (= (length (the ,ltype ,argname)) + ,(dd-length defstruct)) + (eq ',name (aref (the ,ltype ,argname) ,name-index)))) (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S." - ltype))) - (eq (elt (the ,ltype ,argname) - ,name-index) - ',name)))))))) + ltype)))))))))) ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. (defun typed-copier-definitions (defstruct) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index cc4c796..8f2f5b2 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -521,6 +521,27 @@ (eval (copy-tree form)) (eval (copy-tree form))) +;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists" +;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP +;;; test suite. +(defstruct (bug-332a (:type list) (:initial-offset 5) :named)) +(defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a))) +(assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail)))) +(assert (not (bug-332b-p 873257))) +(assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a)))) +(assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b))) + +;;; Similar test for vectors, just for good measure. +(defstruct (bug-332a-aux (:type vector) + (:initial-offset 5) :named)) +(defstruct (bug-332b-aux (:type vector) + (:initial-offset 2) :named + (:include bug-332a-aux))) +(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end)))) +(assert (not (bug-332b-aux-p 873257))) +(assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux)))) +(assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux))) + ;;; success (format t "~&/returning success~%") (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index a725847..e5666ca 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.10.22" +"0.8.10.23" -- 1.7.10.4