Changeset 15400


Ignore:
Timestamp:
May 31, 2012, 8:30:04 AM (7 years ago)
Author:
gb
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:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-clos-boot.lisp

    r15311 r15400  
    12241224
    12251225
    1226 (defun std-instance-class-cell-typep (form class-cell)
     1226(defun class-cell-typep (form class-cell)
    12271227  (let* ((typecode (typecode form))
    12281228         (wrapper (cond ((= typecode target::subtag-instance)
     
    12301230                        ((= typecode target::subtag-basic-stream)
    12311231                         (basic-stream.wrapper form))
    1232                         (t nil))))
     1232                        (t (non-standard-instance-class-wrapper form)))))
    12331233    (declare (type (unsigned-byte 8) typecode))
    1234     (when wrapper
    1235       (loop
     1234    (loop
    12361235        (let ((class (class-cell-class class-cell)))
    12371236          (if class
     
    12511250                  (if (and new-cell (not (eq class-cell new-cell)))
    12521251                    (setq class-cell new-cell class (class-cell-class class-cell))
    1253                     (return (typep form name)))))))))))
    1254 
    1255 (defun class-cell-typep (form class-cell)
    1256   (locally (declare (type class-cell  class-cell))
    1257     (loop
    1258     (let ((class (class-cell-class class-cell)))
    1259       (if class
    1260         (let* ((ordinal (%class-ordinal class))
    1261                (wrapper (instance-class-wrapper form))
    1262                (bits (or (%wrapper-cpl-bits wrapper)
    1263                          (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
    1264           (declare (fixnum ordinal))
    1265           (return
    1266             (if bits
    1267               (locally (declare (simple-bit-vector bits)
    1268                                 (optimize (speed 3) (safety 0)))
    1269                   (if (< ordinal (length bits))
    1270                     (not (eql 0 (sbit bits ordinal))))))))
    1271         (let* ((name (class-cell-name class-cell))
    1272                (new-cell (find-class-cell name nil)))
    1273           (unless
    1274               (if (and new-cell (not (eq class-cell new-cell)))
    1275                 (setq class-cell new-cell class (class-cell-class class-cell))
    1276                 (return (typep form name))))))))))
     1252                    (return (typep form name))))))))))
     1253
     1254
     1255(%fhave 'std-instance-class-cell-typep #'class-cell-typep)
    12771256
    12781257
     
    12811260  (if (class-cell-typep arg class-cell)
    12821261    arg
    1283     (%kernel-restart $xwrongtype arg (car class-cell))))
     1262    (%kernel-restart $xwrongtype arg (class-cell-class class-cell))))
    12841263
    12851264
     
    14981477(defun make-cpl-bits (cpl)
    14991478  (declare (optimize speed))
    1500   (when cpl
     1479  (when cpl 
    15011480    (let* ((max 0))
    15021481      (declare (fixnum max))
     
    25032482  (and (classp c1)
    25042483       (classp c2)
    2505        (not (null (memq c2 (%inited-class-cpl c1 t))))))
     2484       (not (null (memq c2 (or (%class-cpl c1) (ignore-errors (%inited-class-cpl c1 t))))))))
    25062485
    25072486(defun %class-get (class indicator &optional default)
Note: See TracChangeset for help on using the changeset viewer.