0.7.12.9:

	Fix issue in DEFSTRUCT :NAMED :TYPE structure predicates, which
		had a tendency to signal errors on #() or dotted lists.

diff --git a/NEWS b/NEWS
index 406df41..1fbab30 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1508,12 +1508,14 @@ changes in sbcl-0.7.13 relative to sbcl-0.7.12:
   * fixed bug 157: TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and
     UPGRADED-COMPLEX-PART-TYPE now take (ignored, in all situations)
     optional environment arguments, as required by ANSI.
-  * fixed bug 228: primary return values from
-    FUNCTION-LAMBDA-EXPRESSION are either NIL or suitable for input to
-    COMPILE or FUNCTION.
   * fixed bugs in other functions taking environment objects, allowing
     calls with an explicit NIL environment argument to be compiled
     without error.
+  * fixed bug 228: primary return values from
+    FUNCTION-LAMBDA-EXPRESSION are either NIL or suitable for input to
+    COMPILE or FUNCTION.
+  * fixed a bug in DEFSTRUCT: predicates for :NAMED structures with
+    :TYPE will no longer signal errors on innocuous objects.
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** ARRAY-IN-BOUNDS-P now allows arbitrary integers as arguments,
        not just nonnegative fixnums;

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 2a7cebe..a25f997 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -426,11 +426,20 @@
        (predicate-name (dd-predicate-name defstruct))
        (argname (gensym)))
     (when (and predicate-name (dd-named defstruct))
-      (let ((ltype (dd-lisp-type defstruct)))
+      (let ((ltype (dd-lisp-type defstruct))
+           (name-index (cdr (car (last (find-name-indices defstruct))))))
        `((defun ,predicate-name (,argname)
            (and (typep ,argname ',ltype)
+                ,(cond
+                  ((subtypep ltype 'list)
+                   `(consp (nthcdr ,name-index (the ,ltype ,argname))))
+                  ((subtypep ltype 'vector)
+                   `(= (length (the ,ltype ,argname))
+                       ,(dd-length defstruct)))
+                  (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
+                          ltype)))
                 (eq (elt (the ,ltype ,argname)
-                         ,(cdr (car (last (find-name-indices defstruct)))))
+                         ,name-index)
                     ',name))))))))
 
 ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index ae949e9..e195286 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -459,6 +459,23 @@
 (assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
                       undefined-function))
 \f
+;;; The named/typed predicates were a little fragile, in that they
+;;; could throw errors on innocuous input:
+(defstruct (list-struct (:type list) :named) a-slot)
+(assert (list-struct-p (make-list-struct)))
+(assert (not (list-struct-p nil)))
+(assert (not (list-struct-p 1)))
+(defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot)
+(assert (offset-list-struct-p (make-offset-list-struct)))
+(assert (not (offset-list-struct-p nil)))
+(assert (not (offset-list-struct-p 1)))
+(assert (not (offset-list-struct-p '(offset-list-struct))))
+(assert (not (offset-list-struct-p '(offset-list-struct . 3))))
+(defstruct (vector-struct (:type vector) :named) a-slot)
+(assert (vector-struct-p (make-vector-struct)))
+(assert (not (vector-struct-p nil)))
+(assert (not (vector-struct-p #())))
+
 ;;; success
 (format t "~&/returning success~%")
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index d006fc0..1f6a5bc 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.12.8"
+"0.7.12.9"