Changeset 9944


Ignore:
Timestamp:
Jul 10, 2008, 8:56:19 AM (12 years ago)
Author:
gb
Message:

NON-STANDARD-INSTANCE-CLASS-WRAPPER.

STD-INSTANCE-CLASS-CELL-TYPEP.

Access basic-stream.wrapper in class-table function, since
basic-stream.class is no more. (It's slightly faster to
get the class from the wrapper than the other way around,
so we store the wrapper.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r9847 r9944  
    12141214;;;;;;;;;;;;;;;;;;;;;;;;  Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    12151215
     1216(declaim (inline non-standard-instance-class-wrapper))
     1217
     1218(defun non-standard-instance-class-wrapper (instance)
     1219  (let* ((typecode (typecode instance)))
     1220    (declare (type (unsigned-byte 8) typecode))
     1221    (cond ((eql typecode target::subtag-struct)
     1222           (%class.own-wrapper
     1223            (class-cell-class (car (%svref instance 0)))))
     1224          ((eql typecode target::subtag-istruct)
     1225           (istruct-cell-info (%svref instance 0)))
     1226          ((eql typecode target::subtag-basic-stream)
     1227           (basic-stream.wrapper instance))
     1228          ((typep instance 'funcallable-standard-object)
     1229           (gf.instance.class-wrapper instance))
     1230          ((eql typecode target::subtag-macptr) (foreign-instance-class-wrapper instance))
     1231          (t (%class.own-wrapper (class-of instance))))))
    12161232
    12171233(defun instance-class-wrapper (instance)
    1218   (cond ((%standard-instance-p instance) (instance.class-wrapper instance))
    1219         ((structurep instance) (%class.own-wrapper
    1220                                 (class-cell-class (car (%svref instance 0)))))
    1221         ((eql (typecode instance) target::subtag-istruct)
    1222          (istruct-cell-info (%svref instance 0)))
    1223         ((typep instance 'basic-stream)
    1224          (%class.own-wrapper (basic-stream.class instance)))
    1225         ((typep instance 'funcallable-standard-object)
    1226          (gf.instance.class-wrapper instance))
    1227         ((typep instance 'macptr) (foreign-instance-class-wrapper instance))
    1228         (t (%class.own-wrapper (class-of instance)))))
     1234  (if (= (typecode instance)  target::subtag-instance)
     1235    (instance.class-wrapper instance)
     1236    (non-standard-instance-class-wrapper instance)))
     1237
     1238
     1239(defun std-instance-class-cell-typep (form class-cell)
     1240  (when (%standard-instance-p form)
     1241    (locally (declare (type class-cell  class-cell))
     1242      (loop
     1243        (let ((class (class-cell-class class-cell)))
     1244          (if class
     1245            (let* ((ordinal (%class-ordinal class))
     1246                   (wrapper (instance.class-wrapper form))
     1247                   (bits (or (%wrapper-cpl-bits wrapper)
     1248                             (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1249              (declare (fixnum ordinal))
     1250              (return
     1251                (if bits
     1252                  (locally (declare (simple-bit-vector bits)
     1253                                    (optimize (speed 3) (safety 0)))
     1254                    (if (< ordinal (length bits))
     1255                      (not (eql 0 (sbit bits ordinal))))))))
     1256            (let* ((name (class-cell-name class-cell))
     1257                   (new-cell (find-class-cell name nil)))
     1258              (unless
     1259                  (if (and new-cell (not (eq class-cell new-cell)))
     1260                    (setq class-cell new-cell class (class-cell-class class-cell))
     1261                    (return (typep form name)))))))))))
    12291262
    12301263(defun class-cell-typep (form class-cell)
     
    23072340                          *istruct-class*)))))
    23082341        (setf (%svref v target::subtag-basic-stream)
    2309               #'(lambda (b) (basic-stream.class b)))
     2342              #'(lambda (b) (%wrapper-class (basic-stream.wrapper b))))
    23102343        (setf (%svref v target::subtag-instance)
    23112344              #'%class-of-instance)
Note: See TracChangeset for help on using the changeset viewer.