0.9.11.43:

	Fix bug reported by Levente Meszaros sbcl-devel 2004-04-19:
	cache filling with negative offset.
	... when precomputing cache contents, don't include classes with
		invalid wrappers.
	... irony of ironies: I'm pretty sure that there's a bug lurking
		somewhere else in any case, because the problem was
		being exhibited in the computation of a cache for
		SLOT-BOUNDP-USING-CLASS, which doesn't (or shouldn't)
		use a cacheing dfun, but instead has its own specialized
		dfun which basically calls the boundp function from the
		slot definition.  Hmm...
	... comments and minor tidying in cache.lisp

diff --git a/NEWS b/NEWS
index 22a5a9a..cfb3cfd 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -37,6 +37,10 @@ changes in sbcl-0.9.12 relative to sbcl-0.9.11:
     appropriate float range (reported by John Wiseman)
   * bug fix: MAKE-LOAD-FORM-SAVING-SLOTS accepts en empty slot name
     list.
+  * bug fix: precomputing cache entries for generic functions with
+    some subclasses of specializers as yet invalid does not attempt to
+    fill a cache line with a negative offset.  (reported by Levente
+    Mészároz)
   * improvements to DOCUMENTATION for TYPE and STRUCTURE doc-types:
     allow condition class objects as arguments to DOCUMENTATION and
     (SETF DOCUMENTATION); only find and set documentation for

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index 34c148f..4b0fbc4 100644 (file)
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -943,7 +943,7 @@
 
 (defun fill-cache (cache wrappers value)
   ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
-  (assert wrappers)
+  (aver wrappers)
 
   (or (fill-cache-p nil cache wrappers value)
       (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*))
@@ -982,10 +982,7 @@
 
 (defun probe-cache (cache wrappers &optional default limit-fn)
   ;;(declare (values value))
-  (unless wrappers
-    ;; FIXME: This and another earlier test on a WRAPPERS arg can
-    ;; be compact assertoids.
-    (error "WRAPPERS arg is NIL!"))
+  (aver wrappers)
   (with-local-cache-functions (cache)
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
            (limit (funcall (or limit-fn (limit-fn)) (nlines))))
@@ -1041,6 +1038,13 @@
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
            (primary (location-line location)))
       (declare (fixnum location primary))
+      ;; FIXME: I tried (aver (> location 0)) and (aver (not
+      ;; (location-reserved-p location))) here, on the basis that
+      ;; particularly passing a LOCATION of 0 for a cache with more
+      ;; than one key would cause PRIMARY to be -1.  However, the
+      ;; AVERs triggered during the bootstrap, and removing them
+      ;; didn't cause anything to break, so I've left them removed.
+      ;; I'm still confused as to what is right.  -- CSR, 2006-04-20
       (multiple-value-bind (free emptyp)
           (find-free-cache-line primary cache wrappers)
         (when (or forcep emptyp)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 3358df9..9f43c63 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -951,18 +951,19 @@
                (set-structure-svuc-method type method)))))))
 
 (defun mec-all-classes-internal (spec precompute-p)
-  (cons (specializer-class spec)
-        (and (classp spec)
-             precompute-p
-             (not (or (eq spec *the-class-t*)
-                      (eq spec *the-class-slot-object*)
-                      (eq spec *the-class-standard-object*)
-                      (eq spec *the-class-structure-object*)))
-             (let ((sc (class-direct-subclasses spec)))
-               (when sc
-                 (mapcan (lambda (class)
-                           (mec-all-classes-internal class precompute-p))
-                         sc))))))
+  (unless (invalid-wrapper-p (class-wrapper (specializer-class spec)))
+    (cons (specializer-class spec)
+          (and (classp spec)
+               precompute-p
+               (not (or (eq spec *the-class-t*)
+                        (eq spec *the-class-slot-object*)
+                        (eq spec *the-class-standard-object*)
+                        (eq spec *the-class-structure-object*)))
+               (let ((sc (class-direct-subclasses spec)))
+                 (when sc
+                   (mapcan (lambda (class)
+                             (mec-all-classes-internal class precompute-p))
+                           sc)))))))
 
 (defun mec-all-classes (spec precompute-p)
   (let ((classes (mec-all-classes-internal spec precompute-p)))

diff --git a/tests/mop-14.impure-cload.lisp b/tests/mop-14.impure-cload.lisp
new file mode 100644 (file)
index 0000000..e2af7fc
--- /dev/null
+++ b/tests/mop-14.impure-cload.lisp
@@ -0,0 +1,52 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; this file attempts to test the computation of final discriminating
+;;; functions for slot-valuish generic functions in the presence of
+;;; large hierarchies of slot definitions with a forward-referenced
+;;; superclass.  (This used to fail in cache-filling code: see reports
+;;; from Levente Mészáros sbcl-devel 2006-04-19)
+
+(defpackage :dc
+  (:use
+    #:cl
+    #:sb-mop))
+
+(in-package :dc)
+
+(defclass dwim-slot-definition
+  (standard-slot-definition)
+  ())
+
+(defclass dwim-direct-slot-definition
+  (standard-direct-slot-definition dwim-slot-definition)
+  ())
+
+(defclass dwim-effective-slot-definition
+  (extra-effective-slot-definition
+   standard-effective-slot-definition dwim-slot-definition)
+  ())
+(defclass dwim-attribute-slot-definition
+  (dwim-slot-definition)
+  ())
+
+(defclass dwim-attribute-effective-slot-definition
+  (dwim-effective-slot-definition dwim-attribute-slot-definition)
+  ())
+
+(defclass dwim-attribute-direct-slot-definition
+  (dwim-direct-slot-definition dwim-attribute-slot-definition)
+  ())
+
+(defclass extra-effective-slot-definition ()
+  ())

diff --git a/version.lisp-expr b/version.lisp-expr
index 442dd50..727d7c1 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.11.42"
+"0.9.11.43"