X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=043e0da3dad61d7b6a10cedd91e57c7a057c3eb5;hb=aebbc5aad31f7e55930c996a8c54f0a135e00894;hp=e6ab1ccef791de1ee0bba4517f69c77c518b3d09;hpb=a736ac10b709b2d40305f0a6e3764afd246a8ef5;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index e6ab1cc..043e0da 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -443,15 +443,15 @@
     (remf initargs :metaclass)
     (loop (unless (remf initargs :direct-superclasses) (return)))
     (loop (unless (remf initargs :direct-slots) (return)))
-    (values meta
-            (list* :direct-superclasses
-                   (and (neq supplied-supers unsupplied)
-                        (mapcar #'fix-super supplied-supers))
-                   :direct-slots
-                   (and (neq supplied-slots unsupplied) supplied-slots)
-                   initargs))))
+    (values
+     meta
+     (nconc
+      (when (neq supplied-supers unsupplied)
+	(list :direct-superclasses (mapcar #'fix-super supplied-supers)))
+      (when (neq supplied-slots unsupplied)
+	(list :direct-slots supplied-slots))
+      initargs))))
 
-
 (defmethod shared-initialize :after
 	   ((class std-class)
 	    slot-names
@@ -530,6 +530,22 @@
 		  (lambda (dependent)
 		    (apply #'update-dependent class dependent initargs))))
 
+(defmethod shared-initialize :after ((class condition-class) slot-names
+				     &key 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 (classoid-pcl-class classoid) class)
+      (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))))
+
 (defmethod shared-initialize :after
     ((slotd structure-slot-definition) slot-names &key
      (allocation :instance) allocation-class)
@@ -653,7 +669,7 @@
                                         (class-name class))))))
     (make-class-predicate class predicate-name)
     (add-slot-accessors class direct-slots)))
-  
+
 (defmethod direct-slot-definition-class ((class structure-class) initargs)
   (declare (ignore initargs))
   (find-class 'structure-direct-slot-definition))
@@ -1151,7 +1167,7 @@
 	      (wrapper-instance-slots-layout owrapper))
 	(setf (wrapper-class-slots nwrapper)
 	      (wrapper-class-slots owrapper))
-	(sb-sys:without-interrupts
+	(with-pcl-lock
 	  (update-lisp-class-layout class nwrapper)
 	  (setf (slot-value class 'wrapper) nwrapper)
 	  (invalidate-wrapper owrapper :flush nwrapper))))))
@@ -1171,7 +1187,7 @@
 	    (wrapper-instance-slots-layout owrapper))
       (setf (wrapper-class-slots nwrapper)
 	    (wrapper-class-slots owrapper))
-      (sb-sys:without-interrupts
+      (with-pcl-lock
 	(update-lisp-class-layout class nwrapper)
 	(setf (slot-value class 'wrapper) nwrapper)
 	(invalidate-wrapper owrapper :obsolete nwrapper)