From 6b6e7abdcb23965b4d649176fdbc4e92ef0dfd4a Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Sat, 24 May 2008 14:41:39 +0000 Subject: [PATCH] Fix issue with slot-value-using-class and get-accessor-method-function. See cmucl-imp, 2008/04/03, PCL bug?. Bug and link to solution provided by Hans Hubner. Solution based on sbcl patch 0.8.14.27. Here's the test case: (in-package :cl-user) (use-package :pcl) (defclass test-metaclass (standard-class) ()) (defmethod validate-superclass ((sub test-metaclass) (super standard-class)) t) (defmethod (setf slot-value-using-class) :before (newval (class test-metaclass) object slotd) (print 'setf-slot-value-using-class-before)) (defmethod (setf slot-value-using-class) :after (newval (class test-metaclass) object slotd) (print 'setf-slot-value-using-class-after)) (defclass test-class () (slot) (:metaclass test-metaclass)) --- pcl/braid.lisp | 3 ++- pcl/defs.lisp | 3 +++ pcl/dfun.lisp | 4 ++-- pcl/std-class.lisp | 12 +++++++++--- 4 files changed, 16 insertions(+), 6 deletions(-) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index cb53b7689..06a2ec5f8 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.50 2007/09/13 13:27:25 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.51 2008/05/24 14:41:39 rtoy Rel $") ;;; ;;; Bootstrapping the meta-braid. @@ -286,6 +286,7 @@ class) spec)) (set-slot 'class-precedence-list (classes cpl)) + (set-slot 'cpl-available-p t) (set-slot 'can-precede-list (classes (cdr cpl))) (set-slot 'incompatible-superclass-list nil) (set-slot 'direct-superclasses (classes direct-supers)) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 8e43fb4ca..17152a071 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -482,6 +482,9 @@ (defclass pcl-class (class) ((class-precedence-list :reader class-precedence-list) + (cpl-available-p + :reader cpl-available-p + :initform nil) (can-precede-list :initform () :reader class-can-precede-list) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index cc7ec2c0e..f4d63faa2 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.38 2005/08/18 16:55:00 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.39 2008/05/24 14:41:39 rtoy Rel $") (in-package :pcl) @@ -1291,7 +1291,7 @@ And so, we are saved. ;;; (defun cpl-or-nil (class) (if (eq *boot-state* 'complete) - (when (class-finalized-p class) + (when (cpl-available-p class) (class-precedence-list class)) (early-class-precedence-list class))) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 60f492ad1..fd6be9cf6 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.82 2006/11/30 15:49:30 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.83 2008/05/24 14:41:39 rtoy Exp $") (in-package :pcl) @@ -714,6 +714,7 @@ (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) + (setf (slot-value class 'cpl-available-p) t) (setf (slot-value class 'slots) (compute-slots class)) (let ((lclass (kernel::find-class (class-name class)))) (setf (kernel:%class-pcl-class lclass) class) @@ -860,8 +861,11 @@ ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMUCL. (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class 'cpl-available-p) t) (force-cache-flushes class)) - (setf (slot-value class 'class-precedence-list) cpl)) + (progn + (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class 'cpl-available-p) t))) (update-class-can-precede-p cpl)) (defun update-class-can-precede-p (cpl) @@ -1655,7 +1659,8 @@ &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((kernel-class (kernel::find-class (class-name class)))) - (with-slots (wrapper class-precedence-list prototype predicate-name + (with-slots (wrapper class-precedence-list cpl-available-p + prototype predicate-name (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) @@ -1666,6 +1671,7 @@ (setq direct-supers direct-superclasses) (setq wrapper (kernel:%class-layout kernel-class)) (setq class-precedence-list (compute-class-precedence-list class)) + (setq cpl-available-p t) (add-direct-subclasses class direct-superclasses) (setq predicate-name (make-class-predicate-name (class-name class))) (make-class-predicate class predicate-name) -- GitLab