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.

diff --git a/BUGS b/BUGS
index 16b98ce..15c55b5 100644 (file)
--- 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 (file)
--- 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 <fun-name> was erroneously
     applied to a call of a value of a variable with name <fun-name>.
     (reported by Antonio Menezes Leitao)

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 391aae1..0660f8e 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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"