Changeset 15400

Timestamp:

May 31, 2012, 1:30:04 AM (12 years ago)

Author:

Gary Byers

Message:

CLASS-CELL-TYPEP and STD-INSTANCE-CLASS-CELL-TYPEP are equivalent.
In SUBTYPEP, ignore-errors if c1's CPL can't be computed.

File:

• trunk/source/level-1/l1-clos-boot.lisp (modified) (6 diffs)

trunk/source/level-1/l1-clos-boot.lisp

@@ -1224 +1224 @@
 
 
-(defun std-instance-class-cell-typep (form class-cell)
+(defun class-cell-typep (form class-cell)
   (let* ((typecode (typecode form))
          (wrapper (cond ((= typecode target::subtag-instance)
@@ -1230 +1230 @@
                         ((= typecode target::subtag-basic-stream)
                          (basic-stream.wrapper form))
-                        (t nil))))
+                        (t (non-standard-instance-class-wrapper form)))))
     (declare (type (unsigned-byte 8) typecode))
-    (when wrapper
-      (loop
+    (loop
         (let ((class (class-cell-class class-cell)))
           (if class
@@ -1251 +1250 @@
                   (if (and new-cell (not (eq class-cell new-cell)))
                     (setq class-cell new-cell class (class-cell-class class-cell))
-                    (return (typep form name)))))))))))
-
-(defun class-cell-typep (form class-cell)
-  (locally (declare (type class-cell  class-cell))
-    (loop
-    (let ((class (class-cell-class class-cell)))
-      (if class
-        (let* ((ordinal (%class-ordinal class))
-               (wrapper (instance-class-wrapper form))
-               (bits (or (%wrapper-cpl-bits wrapper)
-                         (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
-          (declare (fixnum ordinal))
-          (return
-            (if bits
-              (locally (declare (simple-bit-vector bits)
-                                (optimize (speed 3) (safety 0)))
-                  (if (< ordinal (length bits))
-                    (not (eql 0 (sbit bits ordinal))))))))
-        (let* ((name (class-cell-name class-cell))
-               (new-cell (find-class-cell name nil)))
-          (unless
-              (if (and new-cell (not (eq class-cell new-cell)))
-                (setq class-cell new-cell class (class-cell-class class-cell))
-                (return (typep form name))))))))))
+                    (return (typep form name))))))))))
+
+
+(%fhave 'std-instance-class-cell-typep #'class-cell-typep)
 
 
@@ -1281 +1260 @@
   (if (class-cell-typep arg class-cell)
     arg
-    (%kernel-restart $xwrongtype arg (car class-cell))))
+    (%kernel-restart $xwrongtype arg (class-cell-class class-cell))))
 
 
@@ -1498 +1477 @@
 (defun make-cpl-bits (cpl)
   (declare (optimize speed))
-  (when cpl
+  (when cpl  
     (let* ((max 0))
       (declare (fixnum max))
@@ -2503 +2482 @@
   (and (classp c1)
        (classp c2)
-       (not (null (memq c2 (%inited-class-cpl c1 t))))))
+       (not (null (memq c2 (or (%class-cpl c1) (ignore-errors (%inited-class-cpl c1 t))))))))
 
 (defun %class-get (class indicator &optional default)