From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 28 Jan 2003 17:21:09 +0000 (+0000)
Subject: 0.7.12.9:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8922e16df316133288d46695ff2d7596c397a6a0;p=sbcl.git

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
--- 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
--- 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
--- 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))
 
+;;; 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
--- 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"