Index: /branches/working-0711/ccl/level-1/l1-clos-boot.lisp
===================================================================
--- /branches/working-0711/ccl/level-1/l1-clos-boot.lisp	(revision 7944)
+++ /branches/working-0711/ccl/level-1/l1-clos-boot.lisp	(revision 7945)
@@ -1181,14 +1181,17 @@
 
 (defun class-cell-typep (form class-cell)
-  (unless (istruct-typep  class-cell 'class-cell)
-    (report-bad-arg class-cell 'class-cell))
   (locally (declare (type class-cell  class-cell))
     (let ((class (class-cell-class class-cell)))
-      (when (not class)
-        (setq class (find-class (class-cell-name class-cell) nil))
-        (when class (setf (class-cell-class class-cell) class)))
-      (if class
-        (not (null (memq class (%inited-class-cpl (class-of form)))))
-        (if (fboundp 'typep)(typep form (class-cell-name class-cell)) t)))))
+      (loop
+        (if class
+          (let* ((wrapper (if (%standard-instance-p form)
+                            (instance.class-wrapper form)
+                            (instance-class-wrapper form))))
+            (return
+              (not (null (memq class (or (%wrapper-cpl wrapper)
+                                         (%inited-class-cpl (%wrapper-class wrapper))))))))
+          (if (setq class (find-class (class-cell-name class-cell) nil))
+            (setf (class-cell-class class-cell) class)
+            (return (typep form (class-cell-name class-cell)))))))))
 
 
@@ -1303,5 +1306,5 @@
 
 
-#|
+#||
 ; This tended to cluster entries in gf dispatch tables too much.
 (defvar *class-wrapper-hash-index* 0)
@@ -1314,5 +1317,5 @@
           (%i+ index 3)                 ; '3 = 24 bytes = 6 longwords in lap.
           1))))
-|#
+||#
 
 
@@ -1385,6 +1388,9 @@
       (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
     (setf (%class.local-supers class) supers)
-    (setf (%class.cpl class) (compute-cpl class))
-    (setf (%class.own-wrapper class) (%cons-wrapper class (new-class-wrapper-hash-index)))
+    (let* ((wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))
+           (cpl (compute-cpl class)))
+      (setf (%class.cpl class) cpl)
+      (setf (%class.own-wrapper class) wrapper)
+      (setf (%wrapper-cpl wrapper) cpl))
     (setf (%class.ctype class)  (make-class-ctype class))
     (setf (find-class name) class)
@@ -2528,4 +2534,5 @@
 	 (type-predicate (standard-effective-slot-definition.type-predicate slotd)))
     (unless (or (eq new (%slot-unbound-marker))
+                (null type-predicate)
 		(funcall type-predicate new))
       (error 'bad-slot-type
@@ -2756,4 +2763,5 @@
      (when forwarding-info
        (setf (%wrapper-hash-index wrapper) 0
+             (%wrapper-cpl wrapper) nil
              (%wrapper-instance-slots wrapper) 0
              (%wrapper-forwarding-info wrapper) forwarding-info
@@ -3435,9 +3443,13 @@
 (setf (fdefinition '%do-remove-direct-method) #'remove-direct-method)
 
+(defmethod instance-class-wrapper (x)
+  (%class.own-wrapper (class-of x)))
+
 (defmethod instance-class-wrapper ((instance standard-object))
   (if (%standard-instance-p instance)
     (instance.class-wrapper instance)
     (if (typep instance 'macptr)
-      (foreign-instance-class-wrapper instance))))
+      (foreign-instance-class-wrapper instance)
+      (%class.own-wrapper (class-of instance)))))
 
 (defmethod instance-class-wrapper ((instance standard-generic-function))