0.8.13.28:

	Improve metacycle resolution (from test case from Bruno Haible
	"vicious metacycle when ..." sbcl-devel 2004-08-02)
	... find the slot reader specialized on the nearest class in the
		CPL, not just in the identical class;
	... incorporate Bruno's test case.

diff --git a/NEWS b/NEWS
index 931edba..7edd1d8 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -20,6 +20,9 @@ changes in sbcl-0.8.14 relative to sbcl-0.8.13:
     left shifts.
   * bug fix: provide default methods for INPUT-STREAM-P and
     OUTPUT-STREAM-P specialized on SB-GRAY:FUNDAMENTAL-STREAM.
+  * bug fix: improve the detection and resolution of MOP metacycles
+    (where effective method computation depends on the generic function
+    having its effective method computed).  (reported by Bruno Haible)
   * optimization: in taking the GCD of bignums, reduce the two bignums
     to approximately the same size (using Euclid's algorithm) before
     applying the more sophisticated binary GCD.  (thanks to Juho

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 6988c34..bcce170 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -1215,15 +1215,22 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; function GF which reads/writes instances of class CLASS.
 ;;; TYPE is one of the symbols READER or WRITER.
 (defun find-standard-class-accessor-method (gf class type)
-  (dolist (method (standard-slot-value/gf gf 'methods))
-    (let ((specializers (standard-slot-value/method method 'specializers))
-         (qualifiers (plist-value method 'qualifiers)))
-      (when (and (null qualifiers)
-                (eq (ecase type
-                      (reader (car specializers))
-                      (writer (cadr specializers)))
-                    class))
-       (return method)))))
+  (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+       (found-specializer *the-class-t*)
+       (found-method nil))
+    (dolist (method (standard-slot-value/gf gf 'methods) found-method)
+      (let ((specializers (standard-slot-value/method method 'specializers))
+           (qualifiers (plist-value method 'qualifiers)))
+       (when (and (null qualifiers)
+                  (let ((subcpl (member (ecase type
+                                          (reader (car specializers))
+                                          (writer (cadr specializers)))
+                                        cpl)))
+                    (and subcpl (member found-specializer subcpl))))
+         (setf found-specializer (ecase type
+                                   (reader (car specializers))
+                                   (writer (cadr specializers))))
+         (setf found-method method))))))
 
 (defun accessor-values (gf arg-info classes methods)
   (declare (ignore gf))

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index d682450..648b43b 100644 (file)
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -286,5 +286,50 @@
   (funcall fun)
   (assert (= *special-ssvuc-counter-2* 1)))
 \f
+;;; vicious metacycle detection and resolution wasn't good enough: it
+;;; didn't take account that the slots (and hence the slot readers)
+;;; might be inherited from superclasses.  This example, due to Bruno
+;;; Haible, also tests programmatic addition of accessors.
+(defclass auto-accessors-direct-slot-definition-class (standard-class)
+  ((containing-class-name :initarg :containing-class-name)))
+(defmethod validate-superclass
+    ((c1 auto-accessors-direct-slot-definition-class) (c2 standard-class))
+  t)
+(defclass auto-accessors-class (standard-class)
+  ())
+(defmethod direct-slot-definition-class ((class auto-accessors-class)
+                                        &rest initargs)
+  (let ((dsd-class-name (gensym)))
+    (sb-pcl:ensure-class
+     dsd-class-name
+     :metaclass 'auto-accessors-direct-slot-definition-class
+     :direct-superclasses (list (find-class 'standard-direct-slot-definition))
+     :containing-class-name (class-name class))
+    (eval `(defmethod initialize-instance :after ((dsd ,dsd-class-name)
+                                                 &rest args)
+           (when (and (null (slot-definition-readers dsd))
+                      (null (slot-definition-writers dsd)))
+             (let* ((containing-class-name
+                     (slot-value (class-of dsd) 'containing-class-name))
+                    (accessor-name
+                     (intern
+                      (concatenate 'string
+                                   (symbol-name containing-class-name)
+                                   "-"
+                                   (symbol-name (slot-definition-name dsd)))
+                      (symbol-package containing-class-name))))
+               (setf (slot-definition-readers dsd) (list accessor-name))
+               (setf (slot-definition-writers dsd)
+                     (list (list 'setf accessor-name)))))))
+    (find-class dsd-class-name)))
+(defmethod validate-superclass ((c1 auto-accessors-class) (c2 standard-class))
+  t)
+(defclass testclass15 ()
+  ((x :initarg :x) (y))
+  (:metaclass auto-accessors-class))
+(let ((inst (make-instance 'testclass15 :x 12)))
+  (assert (equal (list (testclass15-x inst) (setf (testclass15-y inst) 13))
+                '(12 13))))
+\f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 82995d7..be62a90 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.8.13.27"
+"0.8.13.28"