0.8.0.70:

[sbcl.git] / src / pcl / std-class.lisp

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 5ac2608..50fd53a 100644 (file)
--- 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)