X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=fdc3ebb4c673b27637a040debe47143b7b87c5ba;hb=80f222325e1f677e5cf8de01c6990906fa47f65d;hp=46cdf63c861965a38b15f4371c9ace1d25a52c54;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 46cdf63..fdc3ebb 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
@@ -279,7 +285,11 @@
 
 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
   (declare (ignore slot-names))
-  (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
+  (setf (slot-value specl 'type)
+        `(eql ,(specializer-object specl)))
+  (setf (info :type :translator specl)
+        (constantly (make-member-type :members (list (specializer-object specl))))))
+
 
 (defun real-load-defclass (name metaclass-name supers slots other)
   (let ((res (apply #'ensure-class name :metaclass metaclass-name
@@ -588,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)
@@ -1031,13 +1040,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
@@ -1046,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))
@@ -1079,7 +1102,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)))