0.8.12.24: Stomping on a PCL buglet

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 76edec5..382a235 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -133,6 +133,10 @@
                  (allocate-instance class)
                  (allocate-standard-instance wrapper))))))
 
+(defmethod class-prototype ((class condition-class))
+  (with-slots (prototype) class
+    (or prototype (setf prototype (allocate-instance class)))))
+
 (defmethod class-direct-default-initargs ((class slot-class))
   (plist-value class 'direct-default-initargs))
 
@@ -141,6 +145,8 @@
 
 (defmethod class-slot-cells ((class std-class))
   (plist-value class 'class-slot-cells))
+(defmethod (setf class-slot-cells) (new-value (class std-class))
+  (setf (plist-value class 'class-slot-cells) new-value))
 \f
 ;;;; class accessors that are even a little bit more complicated than those
 ;;;; above. These have a protocol for updating them, we must implement that
@@ -592,7 +598,6 @@
       (setq direct-supers direct-superclasses)
       (setq wrapper (classoid-layout classoid))
       (setq class-precedence-list (compute-class-precedence-list class))
-      (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)
@@ -1040,8 +1045,20 @@
               (incf location))
              (:class
               (let* ((name (slot-definition-name eslotd))
-                     (from-class (slot-definition-allocation-class eslotd))
-                     (cell (assq name (class-slot-cells from-class))))
+                     (from-class 
+                      (or 
+                       (slot-definition-allocation-class eslotd)
+                       ;; we get here if the user adds an extra slot
+                       ;; himself...
+                       (setf (slot-definition-allocation-class eslotd) 
+                             class)))
+                     ;; which raises the question of what we should
+                     ;; do if we find that said user has added a slot
+                     ;; with the same name as another slot...
+                     (cell (or (assq name (class-slot-cells from-class))
+                               (setf (class-slot-cells from-class)
+                                     (cons (cons name +slot-unbound+)
+                                           (class-slot-cells from-class))))))
                 (aver (consp cell))
                 (if (eq +slot-unbound+ (cdr cell))
                     ;; We may have inherited an initfunction
@@ -1050,6 +1067,8 @@
                           (rplacd cell (funcall initfun))
                           cell))
                     cell)))))
+      (unless (slot-definition-class eslotd)
+       (setf (slot-definition-class eslotd) class))
       (initialize-internal-slot-functions eslotd))))
 
 (defmethod compute-slots ((class funcallable-standard-class))