Changeset 7945


Ignore:
Timestamp:
Dec 26, 2007, 7:54:16 AM (12 years ago)
Author:
gb
Message:

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

File:
1 edited

Legend:

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

    r7888 r7945  
    11811181
    11821182(defun class-cell-typep (form class-cell)
    1183   (unless (istruct-typep  class-cell 'class-cell)
    1184     (report-bad-arg class-cell 'class-cell))
    11851183  (locally (declare (type class-cell  class-cell))
    11861184    (let ((class (class-cell-class class-cell)))
    1187       (when (not class)
    1188         (setq class (find-class (class-cell-name class-cell) nil))
    1189         (when class (setf (class-cell-class class-cell) class)))
    1190       (if class
    1191         (not (null (memq class (%inited-class-cpl (class-of form)))))
    1192         (if (fboundp 'typep)(typep form (class-cell-name class-cell)) t)))))
     1185      (loop
     1186        (if class
     1187          (let* ((wrapper (if (%standard-instance-p form)
     1188                            (instance.class-wrapper form)
     1189                            (instance-class-wrapper form))))
     1190            (return
     1191              (not (null (memq class (or (%wrapper-cpl wrapper)
     1192                                         (%inited-class-cpl (%wrapper-class wrapper))))))))
     1193          (if (setq class (find-class (class-cell-name class-cell) nil))
     1194            (setf (class-cell-class class-cell) class)
     1195            (return (typep form (class-cell-name class-cell)))))))))
    11931196
    11941197
     
    13031306
    13041307
    1305 #|
     1308#||
    13061309; This tended to cluster entries in gf dispatch tables too much.
    13071310(defvar *class-wrapper-hash-index* 0)
     
    13141317          (%i+ index 3)                 ; '3 = 24 bytes = 6 longwords in lap.
    13151318          1))))
    1316 |#
     1319||#
    13171320
    13181321
     
    13851388      (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
    13861389    (setf (%class.local-supers class) supers)
    1387     (setf (%class.cpl class) (compute-cpl class))
    1388     (setf (%class.own-wrapper class) (%cons-wrapper class (new-class-wrapper-hash-index)))
     1390    (let* ((wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))
     1391           (cpl (compute-cpl class)))
     1392      (setf (%class.cpl class) cpl)
     1393      (setf (%class.own-wrapper class) wrapper)
     1394      (setf (%wrapper-cpl wrapper) cpl))
    13891395    (setf (%class.ctype class)  (make-class-ctype class))
    13901396    (setf (find-class name) class)
     
    25282534         (type-predicate (standard-effective-slot-definition.type-predicate slotd)))
    25292535    (unless (or (eq new (%slot-unbound-marker))
     2536                (null type-predicate)
    25302537                (funcall type-predicate new))
    25312538      (error 'bad-slot-type
     
    27562763     (when forwarding-info
    27572764       (setf (%wrapper-hash-index wrapper) 0
     2765             (%wrapper-cpl wrapper) nil
    27582766             (%wrapper-instance-slots wrapper) 0
    27592767             (%wrapper-forwarding-info wrapper) forwarding-info
     
    34353443(setf (fdefinition '%do-remove-direct-method) #'remove-direct-method)
    34363444
     3445(defmethod instance-class-wrapper (x)
     3446  (%class.own-wrapper (class-of x)))
     3447
    34373448(defmethod instance-class-wrapper ((instance standard-object))
    34383449  (if (%standard-instance-p instance)
    34393450    (instance.class-wrapper instance)
    34403451    (if (typep instance 'macptr)
    3441       (foreign-instance-class-wrapper instance))))
     3452      (foreign-instance-class-wrapper instance)
     3453      (%class.own-wrapper (class-of instance)))))
    34423454
    34433455(defmethod instance-class-wrapper ((instance standard-generic-function))
Note: See TracChangeset for help on using the changeset viewer.