;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
(defun make-wrapper (length class)
(cond
- ((typep class 'std-class)
- (make-wrapper-internal
- :length length
- :classoid
- (let ((owrap (class-wrapper class)))
- (cond (owrap
- (layout-classoid owrap))
- ((*subtypep (class-of class)
- *the-class-standard-class*)
- (cond ((and *pcl-class-boot*
- (eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (find-classoid
- (slot-value class 'name))))
- (unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
- (aver (eq (classoid-pcl-class found) class))
- found))
- (t
- (make-standard-classoid :pcl-class class))))
- (t
- (make-random-pcl-classoid :pcl-class class))))))
- (t
- (let* ((found (find-classoid (slot-value class 'name)))
- (layout (classoid-layout found)))
- (unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
- (aver (eq (classoid-pcl-class found) class))
- (aver layout)
- layout))))
+ ((or (typep class 'std-class)
+ (typep class 'forward-referenced-class))
+ (make-wrapper-internal
+ :length length
+ :classoid
+ (let ((owrap (class-wrapper class)))
+ (cond (owrap
+ (layout-classoid owrap))
+ ((or (*subtypep (class-of class) *the-class-standard-class*)
+ (typep class 'forward-referenced-class))
+ (cond ((and *pcl-class-boot*
+ (eq (slot-value class 'name) *pcl-class-boot*))
+ (let ((found (find-classoid
+ (slot-value class 'name))))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
+ found))
+ (t
+ (make-standard-classoid :pcl-class class))))
+ (t
+ (make-random-pcl-classoid :pcl-class class))))))
+ (t
+ (let* ((found (find-classoid (slot-value class 'name)))
+ (layout (classoid-layout found)))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
+ (aver layout)
+ layout))))
(defconstant +first-wrapper-cache-number-index+ 0)
(defun check-wrapper-validity (instance)
(let* ((owrapper (wrapper-of instance))
(state (layout-invalid owrapper)))
- (if (null state)
- owrapper
- (ecase (car state)
- (:flush
- (flush-cache-trap owrapper (cadr state) instance))
- (:obsolete
- (obsolete-instance-trap owrapper (cadr state) instance))))))
+ (aver (not (eq state :uninitialized)))
+ (etypecase state
+ (null owrapper)
+ ;; FIXME: I can't help thinking that, while this does cure the
+ ;; symptoms observed from some class redefinitions, this isn't
+ ;; the place to be doing this flushing. Nevertheless... --
+ ;; CSR, 2003-05-31
+ ;;
+ ;; CMUCL comment:
+ ;; We assume in this case, that the :INVALID is from a
+ ;; previous call to REGISTER-LAYOUT for a superclass of
+ ;; INSTANCE's class. See also the comment above
+ ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
+ ((member t)
+ (force-cache-flushes (class-of instance))
+ (check-wrapper-validity instance))
+ (cons
+ (ecase (car state)
+ (:flush
+ (flush-cache-trap owrapper (cadr state) instance))
+ (:obsolete
+ (obsolete-instance-trap owrapper (cadr state) instance)))))))
(declaim (inline check-obsolete-instance))
(defun check-obsolete-instance (instance)