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