X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=c3af80d3fceb023ca87b42b4ddf204a44066098b;hb=dcb73f3edef1e31078fbe585e2fafbd26743efd7;hp=4cd2a924c9c3fba490bcd87a897f3c18efcd2678;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 4cd2a92..c3af80d 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -145,6 +145,10 @@ ;; 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. @@ -199,7 +203,9 @@ (pure nil :type (member t nil 0)) ;; Number of raw words at the end. ;; This slot is known to the C runtime support code. - (n-untagged-slots 0 :type index)) + (n-untagged-slots 0 :type index) + ;; Definition location + (source-location nil)) (def!method print-object ((layout layout) stream) (print-unreadable-object (layout stream :type t :identity t) @@ -245,6 +251,9 @@ ;; 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* @@ -668,29 +677,13 @@ ;; 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))) ;;;; classoid namespace @@ -779,7 +772,18 @@ NIL is returned when no such class exists." (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)) @@ -816,6 +820,38 @@ NIL is returned when no such class exists." (!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. @@ -825,6 +861,7 @@ NIL is returned when no such class exists." (!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) @@ -848,6 +885,7 @@ NIL is returned when no such class exists." (!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 @@ -861,8 +899,8 @@ NIL is returned when no such class exists." ;; 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) @@ -906,12 +944,16 @@ NIL is returned when no such class exists." ;;;; 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))) ;;;; built-in classes @@ -1423,11 +1465,15 @@ NIL is returned when no such class exists." ;;; 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) @@ -1476,6 +1522,13 @@ NIL is returned when no such class exists." (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*")) (!defun-from-collected-cold-init-forms !classes-cold-init)