From 21ff212864ff015b34b0cdc82b40c990e71a5c71 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 5 Aug 2004 13:12:56 +0000 Subject: [PATCH] 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. --- NEWS | 3 +++ src/pcl/dfun.lisp | 25 ++++++++++++++++--------- tests/mop.impure.lisp | 45 +++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 65 insertions(+), 10 deletions(-) diff --git a/NEWS b/NEWS index 931edba..7edd1d8 100644 --- 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 --- 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 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -286,5 +286,50 @@ (funcall fun) (assert (= *special-ssvuc-counter-2* 1))) +;;; 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)))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 82995d7..be62a90 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.8.13.27" +"0.8.13.28" -- 1.7.10.4