X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=50fd53a2f643bbadd133b239276609d4c6e8b248;hb=77869604fc3eb4417a630651e5fe40e74342ee59;hp=5ac26081b952cc22788572e5c4d34d8c6b64cf20;hpb=b3b4928dfd6f19e3cb4fafe16873ea14a5ef9a4d;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 5ac2608..50fd53a 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -336,8 +336,14 @@
 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
-(defun ensure-class (name &rest all)
-  (apply #'ensure-class-using-class (find-class name nil) name all))
+(defun ensure-class (name &rest args)
+  (apply #'ensure-class-using-class
+	 (let ((class (find-class name nil)))
+	   (when (and class (eq name (class-name class)))
+	     ;; NAME is the proper name of CLASS, so redefine it
+	     class))
+	 name
+	 args))
 
 (defmethod ensure-class-using-class ((class null) name &rest args &key)
   (multiple-value-bind (meta initargs)
@@ -606,12 +612,15 @@
 		    (apply #'update-dependent class dependent initargs))))
 
 (defmethod shared-initialize :after ((class condition-class) slot-names
-				     &key direct-superclasses)
+				     &key direct-slots direct-superclasses)
   (declare (ignore slot-names))
   (let ((classoid (find-classoid (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 (classoid-pcl-class classoid) class)
       (setq direct-supers direct-superclasses)
@@ -620,7 +629,62 @@
       (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))))
+  ;; Comment from Gerd's PCL, 2003-05-15:
+  ;;
+  ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
+  ;; override condition accessors with generic functions.  We do this
+  ;; differently.
+  (update-pv-table-cache-info 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))
+  (aver (slot-value class 'finalized-p))
+  nil)
+
+(defmethod compute-effective-slot-definition
+    ((class condition-class) slot-name dslotds)
+  (let ((slotd (call-next-method)))
+    (setf (slot-definition-reader-function slotd)
+	  (lambda (x)
+	    (handler-case (condition-reader-function x slot-name)
+	      ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
+	      ;; is unbound; maybe it should be a CELL-ERROR of some
+	      ;; sort?
+	      (error () (slot-unbound class x slot-name)))))
+    (setf (slot-definition-writer-function slotd)
+	  (lambda (v x)
+	    (condition-writer-function x v slot-name)))
+    (setf (slot-definition-boundp-function slotd)
+	  (lambda (x)
+	    (multiple-value-bind (v c)
+		(ignore-errors (condition-reader-function x slot-name))
+	      (declare (ignore v))
+	      (null c))))
+    slotd))
+
+(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))))
+
+(defmethod compute-slots :around ((class condition-class))
+  (let ((eslotds (call-next-method)))
+    (mapc #'initialize-internal-slot-functions eslotds)
+    eslotds))
 
 (defmethod shared-initialize :after
     ((slotd structure-slot-definition) slot-names &key
@@ -931,7 +995,8 @@
 	      wrapper nwrapper))
       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
-	(update-pv-table-cache-info class)))))
+	(update-pv-table-cache-info class)
+	(maybe-update-standard-class-locations class)))))
 
 (defun compute-class-slots (eslotds)
   (let (collect)