From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 25 Jul 2006 16:06:31 +0000 (+0000)
Subject: 0.9.14.32:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=42938a8cffe21be4b5a50d2253bbe76bab25e16a;p=sbcl.git

0.9.14.32:
	Bandage for James Y Knight "internal PCL type error" sbcl-devel
	2006-06-20.
	... don't let invalid-wrappers near a cache in MAKE-EMF-CACHE.
	... test case (+ whitespace)

	Note that MAKE-EMF-CACHE via MEC-ALL-CLASSES-FOO functions is
	hideously written, and will perform the same work several times,
	pointlessly.  Rather than build up several large lists with
	duplicated class lists between them, it might be sensible to
	perform some kind of walk down the class hierarchies, performing
	wrapper invalidation and regeneration and class finalization as
	required.
---

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 04f8dd5..adb89d8 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1039,7 +1039,11 @@
                      ;; invalidate wrappers.
                      (let ((wrappers (get-wrappers-from-classes
                                       nkeys wrappers classes metatypes)))
-                       (setq cache (fill-cache cache wrappers value)))))))))
+                       (when (if (atom wrappers)
+                                 (not (invalid-wrapper-p wrappers))
+                                 (every (complement #'invalid-wrapper-p)
+                                        wrappers))
+                         (setq cache (fill-cache cache wrappers value))))))))))
       (if classes-list
           (mapc #'add-class-list classes-list)
           (dolist (method (generic-function-methods generic-function))
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 02862cf..ab9f9b3 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -866,7 +866,7 @@
               wrapper nwrapper)
         (do* ((slots (slot-value class 'slots) (cdr slots))
               (dupes nil))
-             ((null slots) 
+             ((null slots)
               (when dupes
                 (style-warn
                  "~@<slot names with the same SYMBOL-NAME but ~
@@ -875,7 +875,7 @@
                   class dupes)))
           (let* ((slot (car slots))
                  (oslots (remove (slot-definition-name slot) (cdr slots)
-                                 :test #'string/= 
+                                 :test #'string/=
                                  :key #'slot-definition-name)))
             (when oslots
               (pushnew (cons (slot-definition-name slot)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index a1e22b1..27bbf45 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1320,4 +1320,30 @@
 (defclass class-with-odd-class-name-method ()
   ((a :accessor class-name)))
 
+;;; another case where precomputing (this time on PRINT-OBJET) and
+;;; lazily-finalized classes caused problems.  (report from James Y
+;;; Knight sbcl-devel 20-07-2006)
+
+(defclass base-print-object () ())
+;;; this has the side-effect of finalizing BASE-PRINT-OBJECT, and
+;;; additionally the second specializer (STREAM) changes the cache
+;;; structure to require two keys, not just one.
+(defmethod print-object ((o base-print-object) (s stream))
+  nil)
+
+;;; unfinalized as yet
+(defclass sub-print-object (base-print-object) ())
+;;; the accessor causes an eager finalization
+(defclass subsub-print-object (sub-print-object)
+  ((a :accessor a)))
+
+;;; triggers a discriminating function (and so cache) recomputation.
+;;; The method on BASE-PRINT-OBJECT will cause the system to attempt
+;;; to fill the cache for all subclasses of BASE-PRINT-OBJECT which
+;;; have valid wrappers; however, in the course of doing so, the
+;;; SUB-PRINT-OBJECT class gets finalized, which invalidates the
+;;; SUBSUB-PRINT-OBJECT wrapper; if an invalid wrapper gets into a
+;;; cache with more than one key, then failure ensues.
+(reinitialize-instance #'print-object)
+
 ;;;; success
diff --git a/tests/mop-18.impure-cload.lisp b/tests/mop-18.impure-cload.lisp
index 925c4ae..9c298de 100644
--- a/tests/mop-18.impure-cload.lisp
+++ b/tests/mop-18.impure-cload.lisp
@@ -32,7 +32,7 @@
   (when *in-reinitialize-instance*
     (setf *finalized-class* class)))
 
-(defmethod reinitialize-instance :around 
+(defmethod reinitialize-instance :around
     ((class test-standard-class) &key &allow-other-keys)
   (let ((*in-reinitialize-instance* t))
     (call-next-method)))
@@ -52,16 +52,16 @@
 (defclass test-funcallable-standard-class (funcallable-standard-class) ())
 
 (defmethod validate-superclass
-    ((class test-funcallable-standard-class) 
+    ((class test-funcallable-standard-class)
      (superclass funcallable-standard-class))
   t)
 
-(defmethod finalize-inheritance :before 
+(defmethod finalize-inheritance :before
     ((class test-funcallable-standard-class))
   (when *in-reinitialize-instance*
     (setf *finalized-class* class)))
 
-(defmethod reinitialize-instance :around 
+(defmethod reinitialize-instance :around
     ((class test-funcallable-standard-class) &key &allow-other-keys)
   (let ((*in-reinitialize-instance* t))
     (call-next-method)))
@@ -74,7 +74,7 @@
 
 (assert (class-slots (find-class 'test-funcallable-standard-object)))
 (assert (eq *finalized-class* (find-class 'test-standard-object)))
-(reinitialize-instance (find-class 'test-funcallable-standard-object) 
+(reinitialize-instance (find-class 'test-funcallable-standard-object)
                        :direct-slots nil)
 (assert (eq *finalized-class* (find-class 'test-funcallable-standard-object)))
-(assert (null (class-slots (find-class 'test-funcallable-standard-object))))
\ No newline at end of file
+(assert (null (class-slots (find-class 'test-funcallable-standard-object))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 4deb1df..de12751 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.9.14.31"
+"0.9.14.32"