X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=86827210e3d6e118041d52df04e8cc9a7492dca0;hb=434d132bed6f23a9bdc4e35c355cc26b9f454f20;hp=dfee72967cb40bf7b2e5735fada8a275f3d9fccb;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index dfee729..8682721 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 @@ -861,8 +854,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) @@ -875,6 +868,14 @@ NIL is returned when no such class exists." ;; uncertain, since a subclass of both might be defined nil))) +;;; KLUDGE: we need this to deal with the special-case INSTANCE and +;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR +;;; discovered that this was incompatible with the MOP class +;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2 +(defvar *non-instance-classoid-types* + '(symbol system-area-pointer weak-pointer code-component + lra fdefn random-class)) + ;;; KLUDGE: we need this because of the need to represent ;;; intersections of two classes, even when empty at a given time, as ;;; uncanonicalized intersections because of the possibility of later @@ -957,8 +958,6 @@ NIL is returned when no such class exists." (symbol :codes (#.sb!vm:symbol-header-widetag) :prototype-form '#:mu) - (instance :state :read-only) - (system-area-pointer :codes (#.sb!vm:sap-widetag) :prototype-form (sb!sys:int-sap 42)) (weak-pointer :codes (#.sb!vm:weak-pointer-widetag) @@ -974,9 +973,6 @@ NIL is returned when no such class exists." #.sb!vm:simple-fun-header-widetag) :state :read-only :prototype-form (function (lambda () 42))) - (funcallable-instance - :inherits (function) - :state :read-only) (number :translation number) (complex @@ -1288,15 +1284,14 @@ NIL is returned when no such class exists." :prototype-form 'nil) (stream :state :read-only - :depth 3 - :inherits (instance)) + :depth 2) (file-stream :state :read-only - :depth 5 + :depth 4 :inherits (stream)) (string-stream :state :read-only - :depth 5 + :depth 4 :inherits (stream))))) ;;; See also src/code/class-init.lisp where we finish setting up the @@ -1363,15 +1358,15 @@ NIL is returned when no such class exists." (dolist (x '(;; Why is STREAM duplicated in this list? Because, when ;; the inherits-vector of FUNDAMENTAL-STREAM is set up, ;; a vector containing the elements of the list below, - ;; i.e. '(T INSTANCE STREAM STREAM), is created, and + ;; i.e. '(T STREAM STREAM), is created, and ;; this is what the function ORDER-LAYOUT-INHERITS ;; would do, too. ;; ;; So, the purpose is to guarantee a valid layout for ;; the FUNDAMENTAL-STREAM class, matching what ;; ORDER-LAYOUT-INHERITS would do. - ;; ORDER-LAYOUT-INHERITS would place STREAM at index 3 - ;; in the INHERITS(-VECTOR). Index 2 would not be + ;; ORDER-LAYOUT-INHERITS would place STREAM at index 2 + ;; in the INHERITS(-VECTOR). Index 1 would not be ;; filled, so STREAM is duplicated there (as ;; ORDER-LAYOUTS-INHERITS would do). Maybe the ;; duplicate definition could be removed (removing a @@ -1379,7 +1374,7 @@ NIL is returned when no such class exists." ;; redefined after PCL is set up, anyway. But to play ;; it safely, we define the class with a valid INHERITS ;; vector. - (fundamental-stream (t instance stream stream)))) + (fundamental-stream (t stream stream)))) (/show0 "defining temporary STANDARD-CLASS") (let* ((name (first x)) (inherits-list (second x)) @@ -1421,11 +1416,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)