Changeset 7945

Timestamp:

Dec 25, 2007, 11:54:16 PM (17 years ago)

Author:

Gary Byers

Message:

New CLASS-CELL-TYPEP, tries to get CPL from (valid) wrapper.
Maintain CPL in wrapper ...

File:

• branches/working-0711/ccl/level-1/l1-clos-boot.lisp (modified) (7 diffs)

branches/working-0711/ccl/level-1/l1-clos-boot.lisp

@@ -1181 +1181 @@
 
 (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 +1306 @@
 
 
-#|
+#||
 ; This tended to cluster entries in gf dispatch tables too much.
 (defvar *class-wrapper-hash-index* 0)
@@ -1314 +1317 @@
           (%i+ index 3)                 ; '3 = 24 bytes = 6 longwords in lap.
           1))))
-|#
+||#
 
 
@@ -1385 +1388 @@
       (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 +2534 @@
          (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 +2763 @@
      (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 +3443 @@
 (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))