0.9.15.17:

	OK then.  Fix %INSTANCE-TYPEP deftransform
	... if we're testing for a structure-classoid, then any object
		with an invalid layout is neccessarily not typep that
		class.
	... if we're testing for something with a fixed depthoid (i.e.
		something which is always at a given position in the
		layout-inherits), then if we get an object with an
		invalid layout we mustn't throw an error before trying
		to update the object.

diff --git a/NEWS b/NEWS
index 1ca2644..6e3cb20 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15:
     defaults.
   * bug fix: erronous calls to PATHNAME were being optimized away.
     (reported by Richard Kreuter)
+  * bug fix: compiled calls to TYPEP were mishandling obsolete
+    instances.  (reported by James Bielman and Attila Lendvai)
 
 changes in sbcl-0.9.15 relative to sbcl-0.9.14:
   * added support for the ucs-2 external format.  (contributed by Ivan

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index ac421d6..53148b3 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1463,6 +1463,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR"
                ;; FIXME: 32/64-bit issues
                "UNSIGNED-BYTE-32-P" "UNSIGNED-BYTE-64-P"
+               "UPDATE-OBJECT-LAYOUT-OR-INVALID"
                "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-SPECIFIER-TYPE"
                "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
                "VALUES-TYPE" "VALUES-TYPE-ERROR" "VALUES-TYPE-IN"

diff --git a/src/code/class.lisp b/src/code/class.lisp
index dc0b524..0390b9f 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -847,6 +847,11 @@ NIL is returned when no such class exists."
     (ensure-classoid-valid class1 layout1)
     (ensure-classoid-valid class2 layout2)))
 
+(defun update-object-layout-or-invalid (object layout)
+  (if (typep (classoid-of object) 'standard-classoid)
+      (sb!pcl::check-wrapper-validity object)
+      (%layout-invalid-error object layout)))
+
 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
 ;;; the two classes are equal, since there are EQ checks in those
 ;;; operations.

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 36e776a..ca3c349 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -185,11 +185,7 @@
            (values obj-layout layout))
         (aver (< i 2))
         (when (layout-invalid obj-layout)
-          (if (typep (classoid-of object) 'standard-classoid)
-              (setq obj-layout (sb!pcl::check-wrapper-validity object))
-              (error "~S was called on an obsolete object (classoid ~S)."
-                     'typep
-                     (classoid-proper-name (layout-classoid obj-layout)))))
+          (setq obj-layout (update-object-layout-or-invalid object layout)))
         (ensure-classoid-valid classoid layout))
     (let ((obj-inherits (layout-inherits obj-layout)))
       (or (eq obj-layout layout)

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 6405bdd..e5091d1 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -443,9 +443,13 @@
                   (n-layout (gensym)))
               `(and (,pred object)
                     (let ((,n-layout (,get-layout object)))
-                      ,@(when (policy *lexenv* (>= safety speed))
-                              `((when (layout-invalid ,n-layout)
-                                  (%layout-invalid-error object ',layout))))
+                      ;; we used to check for invalid layouts here,
+                      ;; but in fact that's both unnecessary and
+                      ;; wrong; it's unnecessary because structure
+                      ;; classes can't be redefined, and it's wrong
+                      ;; because it is quite legitimate to pass an
+                      ;; object with an invalid layout to a structure
+                      ;; type test.
                       (if (eq ,n-layout ',layout)
                           t
                           (and (> (layout-depthoid ,n-layout)
@@ -456,15 +460,15 @@
                                      ',layout))))))))
            ((and layout (>= (layout-depthoid layout) 0))
             ;; hierarchical layout depths for other things (e.g.
-            ;; CONDITIONs)
+            ;; CONDITION, STREAM)
             (let ((depthoid (layout-depthoid layout))
                   (n-layout (gensym))
                   (n-inherits (gensym)))
               `(and (,pred object)
                     (let ((,n-layout (,get-layout object)))
-                      ,@(when (policy *lexenv* (>= safety speed))
-                          `((when (layout-invalid ,n-layout)
-                              (%layout-invalid-error object ',layout))))
+                      (when (layout-invalid ,n-layout)
+                        (setq ,n-layout (update-object-layout-or-invalid
+                                         object ',layout)))
                       (if (eq ,n-layout ',layout)
                           t
                           (let ((,n-inherits (layout-inherits ,n-layout)))

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index f05a40e..84c7ec3 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1369,4 +1369,18 @@
 (assert (equal '(result) (test-mc27prime 3)))
 (assert (raises-error? (test-mc27 t))) ; still no-applicable-method
 \f
+;;; more invalid wrappers.  This time for a long-standing bug in the
+;;; compiler's expansion for TYPEP on various class-like things, with
+;;; user-visible consequences.
+(defclass obsolete-again () ())
+(defvar *obsolete-again* (make-instance 'obsolete-again))
+(defvar *obsolete-again-hash* (sxhash *obsolete-again*))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (streamp *obsolete-again*)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (= (sxhash *obsolete-again*) *obsolete-again-hash*))
+(compile (defun is-a-structure-object-p (x) (typep x 'structure-object)))
+(make-instances-obsolete (find-class 'obsolete-again))
+(assert (not (is-a-structure-object-p *obsolete-again*)))
+\f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 938b383..5309947 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.9.15.16"
+"0.9.15.17"