X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=5cbb272b555f930c01964c0944ee77de74da4534;hb=f705c517d8606a9a72edd11a96725f9c4e4be93d;hp=76edec5438e133e874ddd58910ad9e9913e78667;hpb=76874d05d623e0001cfcf23d2c74f78295ba6cee;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 76edec5..5cbb272 100644
--- 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))
 
 ;;;; class accessors that are even a little bit more complicated than those
 ;;;; above. These have a protocol for updating them, we must implement that
@@ -581,7 +587,8 @@
 				     &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
+    (with-slots (wrapper class-precedence-list cpl-available-p
+                         prototype predicate-name
 			 (direct-supers direct-superclasses))
 	class
       (setf (slot-value class 'direct-slots)
@@ -592,7 +599,7 @@
       (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)))
+      (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)
@@ -722,12 +729,12 @@
 	instance))))
 
 (defmethod shared-initialize :after
-      ((class structure-class)
-       slot-names
-       &key (direct-superclasses nil direct-superclasses-p)
-	    (direct-slots nil direct-slots-p)
-	    direct-default-initargs
-	    (predicate-name nil predicate-name-p))
+    ((class structure-class)
+     slot-names
+     &key (direct-superclasses nil direct-superclasses-p)
+     (direct-slots nil direct-slots-p)
+     direct-default-initargs
+     (predicate-name nil predicate-name-p))
   (declare (ignore slot-names direct-default-initargs))
   (if direct-superclasses-p
       (setf (slot-value class 'direct-superclasses)
@@ -774,7 +781,8 @@
 	      (make-defstruct-allocation-function class)))
     (add-direct-subclasses class direct-superclasses)
     (setf (slot-value class 'class-precedence-list)
-            (compute-class-precedence-list class))
+          (compute-class-precedence-list class))
+    (setf (slot-value class 'cpl-available-p) t)
     (setf (slot-value class 'slots) (compute-slots class))
     (let ((lclass (find-classoid (class-name class))))
       (setf (classoid-pcl-class lclass) class)
@@ -877,7 +885,7 @@
      (update-cpl class (compute-class-precedence-list class))
      ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
      ;; class.  The hoops above are to ensure that FINALIZE-INHERITANCE
-    ;; is called at finalization, so that MOP programmers can hook
+     ;; is called at finalization, so that MOP programmers can hook
      ;; into the system as described in "Class Finalization Protocol"
      ;; (section 5.5.2 of AMOP).
      (update-slots class (compute-slots class))
@@ -898,8 +906,11 @@
 	;;   Need to have the cpl setup before update-lisp-class-layout
 	;;   is called on CMU CL.
 	(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)
@@ -1035,13 +1046,25 @@
 	(location -1))
     (dolist (eslotd eslotds eslotds)
       (setf (slot-definition-location eslotd)
-	    (ecase (slot-definition-allocation eslotd)
+	    (case (slot-definition-allocation eslotd)
 	      (:instance
 	       (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 +1073,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))
@@ -1083,7 +1108,7 @@
 	  (instance-slots ())
 	  (class-slots ()))
       (dolist (slotd all-slotds)
-	(ecase (slot-definition-allocation slotd)
+	(case (slot-definition-allocation slotd)
 	  (:instance (push slotd instance-slots))
 	  (:class (push slotd class-slots))))
       (let ((layout (compute-layout instance-slots)))