From 88455ffb108a461981a7a9c34ae1d94a53b7a464 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sat, 10 May 2003 19:09:02 +0000
Subject: [PATCH] 	SLOT-EXISTS-P is supposed to work on conditions. 
 Detected 	by Paul Dietz.

	* src/pcl/std-class.lisp (class-direct-slots, class-slots)
	<condition-class>: Remove methods.
	(shared-initialize) <condition-class>: Initialize direct
	and effective slots.
	(direct-slot-definition-class, effective-slot-definition-class)
	(finalize-inheritance, shared-initialize) <condition-class>:
	New methods.

	* src/pcl/braid.lisp (ensure-non-standard-class): Pass slot
	initargs to ensure-class for condition classes.

	* src/pcl/defs.lisp (condition-class): Inherit from slot-class.
	(condition-slot-definition, condition-direct-slot-definition)
	(condition-effective-slot-definition): New classes.
---
 pcl/braid.lisp     | 21 ++++++++++++++++++---
 pcl/defs.lisp      | 15 +++++++++++++--
 pcl/std-class.lisp | 33 ++++++++++++++++++++++++++++-----
 3 files changed, 59 insertions(+), 10 deletions(-)

diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index 9dbd2c07d..8e7a78d18 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.35 2003/05/04 13:11:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.36 2003/05/10 19:09:02 gerd Exp $")
 
 ;;;
 ;;; Bootstrapping the meta-braid.
@@ -529,13 +529,28 @@
 		     ,(structure-slotd-writer-function slotd)))
 	       :type ,(or (structure-slotd-type slotd) t)
 	       :initform ,(structure-slotd-init-form slotd)
-	       :initfunction ,(eval-form (structure-slotd-init-form slotd))))))
+	       :initfunction ,(eval-form (structure-slotd-init-form slotd)))))
+	 (slot-initargs-from-condition-slotd (slot)
+	   `(:name ,(conditions::condition-slot-name slot)
+	     :initargs ,(conditions::condition-slot-initargs slot)
+	     :readers ,(conditions::condition-slot-readers slot)
+	     :writers ,(conditions::condition-slot-writers slot)
+	     ,@(when (conditions::condition-slot-initform-p slot)
+		 (let ((form-or-fn (conditions::condition-slot-initform slot)))
+		   (if (functionp form-or-fn)
+		       `(:initfunction ,form-or-fn)
+		       `(:initform ,form-or-fn))))
+	     :allocation ,(conditions::condition-slot-allocation slot)
+	     :documentation ,(conditions::condition-slot-documentation slot))))
     (cond ((structure-type-p name)
 	   (ensure 'structure-class
 		   (mapcar #'slot-initargs-from-structure-slotd
 			   (structure-type-slot-description-list name))))
 	  ((condition-type-p name)
-	   (ensure 'condition-class))
+	   (let ((class (kernel::find-class name)))
+	     (ensure 'condition-class
+		     (mapcar #'slot-initargs-from-condition-slotd
+			     (conditions::condition-class-slots class)))))
 	  (t
 	   (error "~@<~S is not the name of a class.~@:>" name)))))
 
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index a704827b2..9cc48ce05 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -535,7 +535,7 @@
     :initform nil
     :initarg :from-defclass-p)))
      
-(defclass condition-class (pcl-class) ())
+(defclass condition-class (slot-class) ())
 
 (defclass specializer-with-object (specializer) ())
 
@@ -650,6 +650,9 @@ was inherited."
      :initarg :internal-writer-function
      :accessor slot-definition-internal-writer-function)))
 
+(defclass condition-slot-definition (standard-slot-definition)
+  ())
+
 (defclass direct-slot-definition (slot-definition)
   ())
 
@@ -669,7 +672,7 @@ was inherited."
 
 (defclass standard-effective-slot-definition (standard-slot-definition
 					      effective-slot-definition)
-  ((location ; nil, a fixnum, a cons: (slot-name . value)
+  ((location
     :initform nil
     :accessor slot-definition-location)))
 
@@ -677,10 +680,18 @@ was inherited."
 					    direct-slot-definition)
   ())
 
+(defclass condition-direct-slot-definition (condition-slot-definition
+					    direct-slot-definition)
+  ())
+
 (defclass structure-effective-slot-definition (structure-slot-definition
 					       effective-slot-definition)
   ())
 
+(defclass condition-effective-slot-definition (condition-slot-definition
+					       effective-slot-definition)
+  ())
+
 (defclass method (metaobject) ())
 
 (defclass standard-method (definition-source-mixin documentation-mixin
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 07eae65b5..f0eba8d9d 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.62 2003/05/08 17:29:03 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.63 2003/05/10 19:09:01 gerd Exp $")
 
 (in-package :pcl)
 
@@ -1580,18 +1580,19 @@
 ;;;
 ;;; Conditions
 ;;;
-(defmethod class-direct-slots ((class condition-class)) ())
-(defmethod class-slots ((class condition-class)) ())
 (defmethod class-default-initargs ((class condition-class)) ())
 (defmethod class-direct-default-initargs ((class condition-class)) ())
 
 (defmethod shared-initialize :after ((class condition-class) slot-names
-				     &key direct-superclasses)
+				     &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
 			 (direct-supers direct-superclasses))
 	class
+      (setf (slot-value class 'direct-slots)
+	    (mapcar (lambda (pl) (make-direct-slotd class pl))
+		    direct-slots))
       (setf (slot-value class 'finalized-p) t)
       (setf (kernel:%class-pcl-class kernel-class) class)
       (setq direct-supers direct-superclasses)
@@ -1600,5 +1601,27 @@
       (setq prototype (make-condition (class-name class)))
       (add-direct-subclasses class direct-superclasses)
       (setq predicate-name (make-class-predicate-name (class-name class)))
-      (make-class-predicate class predicate-name))))
+      (make-class-predicate class predicate-name)
+      (setf (slot-value class 'slots) (compute-slots class)))))
 				     
+(defmethod direct-slot-definition-class
+    ((class condition-class) &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'condition-direct-slot-definition))
+
+(defmethod effective-slot-definition-class
+    ((class condition-class) &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'condition-effective-slot-definition))
+
+(defmethod finalize-inheritance ((class condition-class))
+  nil)
+
+(defmethod compute-slots ((class condition-class))
+  (mapcan (lambda (superclass)
+	    (mapcar (lambda (dslotd)
+		      (compute-effective-slot-definition
+		       class (slot-definition-name dslotd) (list dslotd)))
+		    (class-direct-slots superclass)))
+	  (reverse (slot-value class 'class-precedence-list))))
+
-- 
GitLab