;; LAYOUT-CLOS-HASH-MAX by the doc string of that constant,
;; generated as strictly positive in RANDOM-LAYOUT-CLOS-HASH..)
;;
+ ;; [ CSR notes, several years later (2005-11-30) that the value 0 is
+ ;; special for these hash slots, indicating that the wrapper is
+ ;; obsolete. ]
+ ;;
;; KLUDGE: The fact that the slots here start at offset 1 is known
;; to the LAYOUT-CLOS-HASH function and to the LAYOUT-dumping code
;; in GENESIS.
;; They're declared as INDEX.. Or is this a hack to try to avoid
;; having to use bignum arithmetic? Or what? An explanation would be
;; nice.
+ ;;
+ ;; an explanation is provided in Kiczales and Rodriguez, "Efficient
+ ;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
(1+ (random layout-clos-hash-max
(if (boundp '*layout-clos-hash-random-state*)
*layout-clos-hash-random-state*
;; during cold-load.
(translation nil :type (or ctype (member nil :initializing))))
-;;; FIXME: In CMU CL, this was a class with a print function, but not
-;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
-;;; we let CLOS handle our print functions, so that is no longer needed.
-;;; Is there any need for this class any more?
-(def!struct (slot-classoid (:include classoid)
- (:constructor nil)))
-
;;; STRUCTURE-CLASS represents what we need to know about structure
;;; classes. Non-structure "typed" defstructs are a special case, and
;;; don't have a corresponding class.
-(def!struct (basic-structure-classoid (:include slot-classoid)
- (:constructor nil)))
-
-(def!struct (structure-classoid (:include basic-structure-classoid)
+(def!struct (structure-classoid (:include classoid)
(:constructor make-structure-classoid))
;; If true, a default keyword constructor for this structure.
(constructor nil :type (or function null)))
-
-;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
-;;; structures, which are used to implement generic functions.
-(def!struct (funcallable-structure-classoid
- (:include basic-structure-classoid)
- (:constructor make-funcallable-structure-classoid)))
\f
;;;; classoid namespace
(remhash name *forward-referenced-layouts*)
(%note-type-defined name)
- (setf (info :type :kind name) :instance)
+ ;; we need to handle things like
+ ;; (setf (find-class 'foo) (find-class 'integer))
+ ;; and
+ ;; (setf (find-class 'integer) (find-class 'integer))
+ (cond
+ ((built-in-classoid-p new-value)
+ (setf (info :type :kind name) (or (info :type :kind name) :defined))
+ (let ((translation (built-in-classoid-translation new-value)))
+ (when translation
+ (setf (info :type :translator name)
+ (lambda (c) (declare (ignore c)) translation)))))
+ (t (setf (info :type :kind name) :instance)))
(setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
(unless (eq (info :type :compiler-layout name)
(classoid-layout new-value))
(!define-type-class classoid)
+;;; We might be passed classoids with invalid layouts; in any pairwise
+;;; class comparison, we must ensure that both are valid before
+;;; proceeding.
+(defun ensure-classoid-valid (classoid layout)
+ (aver (eq classoid (layout-classoid layout)))
+ (when (layout-invalid layout)
+ (if (typep classoid 'standard-classoid)
+ (let ((class (classoid-pcl-class classoid)))
+ (cond
+ ((sb!pcl:class-finalized-p class)
+ (sb!pcl::force-cache-flushes class))
+ ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
+ (error "Invalid, unfinalizeable class ~S (classoid ~S)."
+ class classoid))
+ (t (sb!pcl:finalize-inheritance class))))
+ (error "Don't know how to ensure validity of ~S (not ~
+ a STANDARD-CLASSOID)." classoid))))
+
+(defun ensure-both-classoids-valid (class1 class2)
+ (do ((layout1 (classoid-layout class1) (classoid-layout class1))
+ (layout2 (classoid-layout class2) (classoid-layout class2))
+ (i 0 (+ i 1)))
+ ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
+ (aver (< i 2))
+ (ensure-classoid-valid class1 layout1)
+ (ensure-classoid-valid class2 layout2)))
+
+(defun update-object-layout-or-invalid (object layout)
+ (if (typep (classoid-of object) 'standard-classoid)
+ (sb!pcl::check-wrapper-validity object)
+ (%layout-invalid-error object layout)))
+
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
;;; operations.
(!define-type-method (classoid :simple-subtypep) (class1 class2)
(aver (not (eq class1 class2)))
+ (ensure-both-classoids-valid class1 class2)
(let ((subclasses (classoid-subclasses class2)))
(if (and subclasses (gethash class1 subclasses))
(values t t)
(!define-type-method (classoid :simple-intersection2) (class1 class2)
(declare (type classoid class1 class2))
+ (ensure-both-classoids-valid class1 class2)
(cond ((eq class1 class2)
class1)
;; If one is a subclass of the other, then that is the
;; Otherwise, we can't in general be sure that the
;; intersection is empty, since a subclass of both might be
;; defined. But we can eliminate it for some special cases.
- ((or (basic-structure-classoid-p class1)
- (basic-structure-classoid-p class2))
+ ((or (structure-classoid-p class1)
+ (structure-classoid-p class2))
;; No subclass of both can be defined.
*empty-type*)
((eq (classoid-state class1) :sealed)
\f
;;;; PCL stuff
-(def!struct (std-classoid (:include classoid)
- (:constructor nil)))
-(def!struct (standard-classoid (:include std-classoid)
+;;; the CLASSOID that we use to represent type information for
+;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
+;;; side does not need to distinguish between STANDARD-CLASS and
+;;; FUNCALLABLE-STANDARD-CLASS.
+(def!struct (standard-classoid (:include classoid)
(:constructor make-standard-classoid)))
-(def!struct (random-pcl-classoid (:include std-classoid)
- (:constructor make-random-pcl-classoid)))
+;;; a metaclass for classes which aren't standardlike but will never
+;;; change either.
+(def!struct (static-classoid (:include classoid)
+ (:constructor make-static-classoid)))
\f
;;;; built-in classes
;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
;;; structure type tests to fail. Remove class from all superclasses
;;; too (might not be registered, so might not be in subclasses of the
-;;; nominal superclasses.)
+;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
+;;; invalidate the wrappers for specialized dispatch functions, which
+;;; use those slots as indexes into tables.
(defun invalidate-layout (layout)
(declare (type layout layout))
(setf (layout-invalid layout) t
(layout-depthoid layout) -1)
+ (dotimes (i layout-clos-hash-length)
+ (setf (layout-clos-hash layout i) 0))
(let ((inherits (layout-inherits layout))
(classoid (layout-classoid layout)))
(modify-classoid classoid)
(let ((layout (classoid-layout (find-classoid name))))
(dolist (code codes)
(setf (svref res code) layout)))))))
+ (setq *null-classoid-layout*
+ ;; KLUDGE: we use (LET () ...) instead of a LOCALLY here to
+ ;; work around a bug in the LOCALLY handling in the fopcompiler
+ ;; (present in 0.9.13-0.9.14.18). -- JES, 2006-07-16
+ (let ()
+ (declare (notinline find-classoid))
+ (classoid-layout (find-classoid 'null))))
#-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
\f
(!defun-from-collected-cold-init-forms !classes-cold-init)
projects / sbcl.git / blobdiff