X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=5646967ccdaeff968432d0a88ccb253cec95a495;hb=755ff8f53315160fcb2d92207dfe24ae7ed4d4c6;hp=0377da29c645a122ef4b4f045772b34b00afcd1d;hpb=d34ac3bbb4a202adfc63d692c77d143e565642cd;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 0377da2..5646967 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -29,7 +29,7 @@ #+sb-xc cl:class (:make-load-form-fun class-make-load-form-fun) (:include ctype - (:class-info (type-class-or-lose #-sb-xc 'sb!xc:class + (class-info (type-class-or-lose #-sb-xc 'sb!xc:class #+sb-xc 'cl:class))) (:constructor nil) #-no-ansi-print-object @@ -52,7 +52,7 @@ ;; that CL:CLASS-NAME is a generic function.) (%name nil :type symbol) ;; the current layout for this class, or NIL if none assigned yet - (layout nil :type (or sb!kernel::layout null)) + (layout nil :type (or layout null)) ;; How sure are we that this class won't be redefined? ;; :READ-ONLY = We are committed to not changing the effective ;; slots or superclasses. @@ -96,7 +96,7 @@ ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM ;;; in order to guarantee that several hash values can be added without ;;; overflowing into a bignum. -(defconstant layout-clos-hash-max (ash most-positive-fixnum -3) +(def!constant layout-clos-hash-max (ash most-positive-fixnum -3) #!+sb-doc "the inclusive upper bound on LAYOUT-CLOS-HASH values") @@ -175,12 +175,12 @@ (clos-hash-6 (random-layout-clos-hash) :type index) (clos-hash-7 (random-layout-clos-hash) :type index) ;; the class that this is a layout for - (class (required-argument) + (class (missing-arg) ;; FIXME: Do we really know this is a CL:CLASS? Mightn't it ;; be a SB-PCL:CLASS under some circumstances? What goes here ;; when the LAYOUT is in fact a PCL::WRAPPER? :type #-sb-xc sb!xc:class #+sb-xc cl:class) - ;; The value of this slot can be + ;; The value of this slot can be: ;; * :UNINITIALIZED if not initialized yet; ;; * NIL if this is the up-to-date layout for a class; or ;; * T if this layout has been invalidated (by being replaced by @@ -188,14 +188,15 @@ ;; * something else (probably a list) if the class is a PCL wrapper ;; and PCL has made it invalid and made a note to itself about it (invalid :uninitialized :type (or cons (member nil t :uninitialized))) - ;; The layouts for all classes we inherit. If hierarchical these are - ;; in order from most general down to (but not including) this - ;; class. + ;; the layouts for all classes we inherit. If hierarchical, i.e. if + ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS, + ;; so that each inherited layout appears at its expected depth, + ;; i.e. at its LAYOUT-DEPTHOID value. ;; - ;; FIXME: Couldn't this be (SIMPLE-ARRAY LAYOUT 1) instead of - ;; SIMPLE-VECTOR? + ;; Remaining elements are filled by the non-hierarchical layouts or, + ;; if they would otherwise be empty, by copies of succeeding layouts. (inherits #() :type simple-vector) - ;; If inheritance is hierarchical, this is -1. If inheritance is not + ;; If inheritance is not hierarchical, this is -1. If inheritance is ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS). ;; Note: ;; (1) This turns out to be a handy encoding for arithmetically @@ -206,7 +207,7 @@ ;; renamed because some of us find it confusing to call something ;; a depth when it isn't quite. (depthoid -1 :type layout-depthoid) - ;; The number of top-level descriptor cells in each instance. + ;; the number of top level descriptor cells in each instance (length 0 :type index) ;; If this layout has some kind of compiler meta-info, then this is ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here. @@ -232,7 +233,7 @@ ;;;; support for the hash values used by CLOS when working with LAYOUTs -(defconstant layout-clos-hash-length 8) +(def!constant layout-clos-hash-length 8) #!-sb-fluid (declaim (inline layout-clos-hash)) (defun layout-clos-hash (layout i) ;; FIXME: Either this I should be declared to be `(MOD @@ -393,8 +394,8 @@ (let ((old-length (layout-length old-layout))) (unless (= old-length length) (warn "change in instance length of class ~S:~% ~ - ~A length: ~D~% ~ - ~A length: ~D" + ~A length: ~W~% ~ + ~A length: ~W" name old-context old-length context length) @@ -440,7 +441,6 @@ (declaim (ftype (function (symbol index simple-vector layout-depthoid) layout) find-and-init-or-check-layout)) (defun find-and-init-or-check-layout (name length inherits depthoid) - (/show0 "entering FIND-AND-INIT-OR-CHECK-LAYOUT") (let ((layout (find-layout name))) (init-or-check-layout layout (or (sb!xc:find-class name nil) @@ -516,13 +516,15 @@ ); EVAL-WHEN ;;; Arrange the inherited layouts to appear at their expected depth, -;;; ensuring that hierarchical type tests succeed. Layouts with a -;;; specific depth are placed first, then the non- hierarchical -;;; layouts fill remaining elements. Any empty elements are filled -;;; with layout copies ensuring that all elements have a valid layout. -;;; This re-ordering may destroy CPL ordering so the inherits should -;;; not be read as being in CPL order, and further duplicates may be -;;; introduced. +;;; ensuring that hierarchical type tests succeed. Layouts with +;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first, +;;; at exactly that index in the INHERITS vector. Then, non-hierarchical +;;; layouts are placed in remaining elements. Then, any still-empty +;;; elements are filled with their successors, ensuring that each +;;; element contains a valid layout. +;;; +;;; This reordering may destroy CPL ordering, so the inherits should +;;; not be read as being in CPL order. (defun order-layout-inherits (layouts) (declare (simple-vector layouts)) (let ((length (length layouts)) @@ -733,6 +735,10 @@ #-sb-xc (declare (type sb!xc:class new-value)) (ecase (info :type :kind name) ((nil)) + (:forthcoming-defclass-type + ;; XXX Currently, nothing needs to be done in this case. Later, when + ;; PCL is integrated tighter into SBCL, this might need more work. + nil) (:instance (let ((old (class-of (sb!xc:find-class name))) (new (class-of new-value))) @@ -911,30 +917,31 @@ (character :enumerable t :translation base-char) (base-char :enumerable t :inherits (character) - :codes (#.sb!vm:base-char-type)) - (symbol :codes (#.sb!vm:symbol-header-type)) + :codes (#.sb!vm:base-char-widetag)) + (symbol :codes (#.sb!vm:symbol-header-widetag)) (instance :state :read-only) - (system-area-pointer :codes (#.sb!vm:sap-type)) - (weak-pointer :codes (#.sb!vm:weak-pointer-type)) - (code-component :codes (#.sb!vm:code-header-type)) - #!-gengc (lra :codes (#.sb!vm:return-pc-header-type)) - (fdefn :codes (#.sb!vm:fdefn-type)) + (system-area-pointer :codes (#.sb!vm:sap-widetag)) + (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)) + (code-component :codes (#.sb!vm:code-header-widetag)) + (lra :codes (#.sb!vm:return-pc-header-widetag)) + (fdefn :codes (#.sb!vm:fdefn-widetag)) (random-class) ; used for unknown type codes (function - :codes (#.sb!vm:byte-code-closure-type - #.sb!vm:byte-code-function-type - #.sb!vm:closure-header-type - #.sb!vm:function-header-type) + :codes (#.sb!vm:closure-header-widetag + #.sb!vm:simple-fun-header-widetag) :state :read-only) (funcallable-instance :inherits (function) :state :read-only) ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything - ;; any more? COLLECTION is not defined in ANSI Common Lisp.. + ;; any more? COLLECTION is not defined in ANSI Common Lisp. + ;; (Zhivago in #lisp IRC 2002-08-14 said that these things, and + ;; also GENERIC-FOO, are related to Dylan functionality and so + ;; truly are irrelevant these days.) (collection :hierarchical-p nil :state :read-only) (mutable-collection :state :read-only :inherits (collection)) @@ -955,11 +962,11 @@ :inherits (generic-array mutable-sequence mutable-collection generic-sequence collection)) - (array :translation array :codes (#.sb!vm:complex-array-type) + (array :translation array :codes (#.sb!vm:complex-array-widetag) :inherits (generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array - :translation simple-array :codes (#.sb!vm:simple-array-type) + :translation simple-array :codes (#.sb!vm:simple-array-widetag) :inherits (array generic-array mutable-sequence mutable-collection generic-sequence collection)) (sequence @@ -967,25 +974,25 @@ :inherits (mutable-sequence mutable-collection generic-sequence collection)) (vector - :translation vector :codes (#.sb!vm:complex-vector-type) + :translation vector :codes (#.sb!vm:complex-vector-widetag) :direct-superclasses (array sequence generic-vector) :inherits (array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-vector - :translation simple-vector :codes (#.sb!vm:simple-vector-type) + :translation simple-vector :codes (#.sb!vm:simple-vector-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (bit-vector - :translation bit-vector :codes (#.sb!vm:complex-bit-vector-type) + :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) :inherits (vector array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-bit-vector - :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-type) + :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag) :direct-superclasses (bit-vector simple-array) :inherits (bit-vector vector simple-array array sequence @@ -993,77 +1000,77 @@ mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-2-type) + :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-4 :translation (simple-array (unsigned-byte 4) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-4-type) + :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-8 :translation (simple-array (unsigned-byte 8) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-8-type) + :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-16 :translation (simple-array (unsigned-byte 16) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-16-type) + :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-unsigned-byte-32 :translation (simple-array (unsigned-byte 32) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-32-type) + :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-8 :translation (simple-array (signed-byte 8) (*)) - :codes (#.sb!vm:simple-array-signed-byte-8-type) + :codes (#.sb!vm:simple-array-signed-byte-8-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-16 :translation (simple-array (signed-byte 16) (*)) - :codes (#.sb!vm:simple-array-signed-byte-16-type) + :codes (#.sb!vm:simple-array-signed-byte-16-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-30 :translation (simple-array (signed-byte 30) (*)) - :codes (#.sb!vm:simple-array-signed-byte-30-type) + :codes (#.sb!vm:simple-array-signed-byte-30-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-signed-byte-32 :translation (simple-array (signed-byte 32) (*)) - :codes (#.sb!vm:simple-array-signed-byte-32-type) + :codes (#.sb!vm:simple-array-signed-byte-32-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-single-float :translation (simple-array single-float (*)) - :codes (#.sb!vm:simple-array-single-float-type) + :codes (#.sb!vm:simple-array-single-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-double-float :translation (simple-array double-float (*)) - :codes (#.sb!vm:simple-array-double-float-type) + :codes (#.sb!vm:simple-array-double-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence @@ -1071,21 +1078,21 @@ #!+long-float (simple-array-long-float :translation (simple-array long-float (*)) - :codes (#.sb!vm:simple-array-long-float-type) + :codes (#.sb!vm:simple-array-long-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-complex-single-float :translation (simple-array (complex single-float) (*)) - :codes (#.sb!vm:simple-array-complex-single-float-type) + :codes (#.sb!vm:simple-array-complex-single-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) (simple-array-complex-double-float :translation (simple-array (complex double-float) (*)) - :codes (#.sb!vm:simple-array-complex-double-float-type) + :codes (#.sb!vm:simple-array-complex-double-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence @@ -1093,7 +1100,7 @@ #!+long-float (simple-array-complex-long-float :translation (simple-array (complex long-float) (*)) - :codes (#.sb!vm:simple-array-complex-long-float-type) + :codes (#.sb!vm:simple-array-complex-long-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence generic-vector generic-array mutable-sequence @@ -1104,7 +1111,7 @@ collection)) (string :translation string - :codes (#.sb!vm:complex-string-type) + :codes (#.sb!vm:complex-string-widetag) :direct-superclasses (vector generic-string) :inherits (vector array sequence generic-vector generic-array generic-string @@ -1112,7 +1119,7 @@ generic-sequence collection)) (simple-string :translation simple-string - :codes (#.sb!vm:simple-string-type) + :codes (#.sb!vm:simple-string-widetag) :direct-superclasses (string simple-array) :inherits (string vector simple-array array sequence @@ -1123,36 +1130,36 @@ :inherits (sequence mutable-sequence mutable-collection generic-sequence collection)) (cons - :codes (#.sb!vm:list-pointer-type) + :codes (#.sb!vm:list-pointer-lowtag) :translation cons :inherits (list sequence mutable-sequence mutable-collection generic-sequence collection)) (null :translation (member nil) - :inherits (list sequence + :inherits (symbol list sequence mutable-sequence mutable-collection - generic-sequence collection symbol) - :direct-superclasses (list symbol)) + generic-sequence collection) + :direct-superclasses (symbol list)) (generic-number :state :read-only) (number :translation number :inherits (generic-number)) (complex :translation complex :inherits (number generic-number) - :codes (#.sb!vm:complex-type)) + :codes (#.sb!vm:complex-widetag)) (complex-single-float :translation (complex single-float) :inherits (complex number generic-number) - :codes (#.sb!vm:complex-single-float-type)) + :codes (#.sb!vm:complex-single-float-widetag)) (complex-double-float :translation (complex double-float) :inherits (complex number generic-number) - :codes (#.sb!vm:complex-double-float-type)) + :codes (#.sb!vm:complex-double-float-widetag)) #!+long-float (complex-long-float :translation (complex long-float) :inherits (complex number generic-number) - :codes (#.sb!vm:complex-long-float-type)) + :codes (#.sb!vm:complex-long-float-widetag)) (real :translation real :inherits (number generic-number)) (float :translation float @@ -1160,37 +1167,37 @@ (single-float :translation single-float :inherits (float real number generic-number) - :codes (#.sb!vm:single-float-type)) + :codes (#.sb!vm:single-float-widetag)) (double-float :translation double-float :inherits (float real number generic-number) - :codes (#.sb!vm:double-float-type)) + :codes (#.sb!vm:double-float-widetag)) #!+long-float (long-float :translation long-float :inherits (float real number generic-number) - :codes (#.sb!vm:long-float-type)) + :codes (#.sb!vm:long-float-widetag)) (rational :translation rational :inherits (real number generic-number)) (ratio :translation (and rational (not integer)) :inherits (rational real number generic-number) - :codes (#.sb!vm:ratio-type)) + :codes (#.sb!vm:ratio-widetag)) (integer :translation integer :inherits (rational real number generic-number)) (fixnum - :translation (integer #.sb!vm:*target-most-negative-fixnum* - #.sb!vm:*target-most-positive-fixnum*) + :translation (integer #.sb!xc:most-negative-fixnum + #.sb!xc:most-positive-fixnum) :inherits (integer rational real number generic-number) - :codes (#.sb!vm:even-fixnum-type #.sb!vm:odd-fixnum-type)) + :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)) (bignum :translation (and integer (not fixnum)) :inherits (integer rational real number generic-number) - :codes (#.sb!vm:bignum-type)) + :codes (#.sb!vm:bignum-widetag)) (stream :state :read-only :depth 3 @@ -1227,7 +1234,7 @@ (if (eq name t) nil (mapcar #'sb!xc:find-class direct-superclasses))))) - (setf (info :type :kind name) :primitive + (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive (class-cell-class (find-class-cell name)) class) (unless trans-p (setf (info :type :builtin name) class)) @@ -1256,17 +1263,25 @@ ;;; is loaded and the class defined. (!cold-init-forms (/show0 "about to define temporary STANDARD-CLASSes") - (dolist (x '(;; FIXME: The mysterious duplication of STREAM in the - ;; list here here was introduced in sbcl-0.6.12.33, in - ;; MNA's port of DTC's inline-type-tests patches for - ;; CMU CL. I'm guessing that it has something to do - ;; with preallocating just enough space in a table - ;; later used by the final definition of - ;; FUNDAMENTAL-STREAM (perhaps for Gray stream stuff?). - ;; It'd be good to document this weirdness both here - ;; and in the REGISTER-LAYOUT code which has to do the - ;; right thing with the duplicates-containing - ;; INHERITS-LIST. + (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 + ;; 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 + ;; filled, so STREAM is duplicated there (as + ;; ORDER-LAYOUTS-INHERITS would do). Maybe the + ;; duplicate definition could be removed (removing a + ;; STREAM element), because FUNDAMENTAL-STREAM is + ;; 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)))) (/show0 "defining temporary STANDARD-CLASS") (let* ((name (first x)) @@ -1327,7 +1342,7 @@ ;;; FIXME: It would be good to arrange for this to be called when the ;;; cross-compiler is being built, not just when the target Lisp is ;;; being cold loaded. Perhaps this could be moved to its own file -;;; late in the stems-and-flags.lisp-expr sequence, and be put in +;;; late in the build-order.lisp-expr sequence, and be put in ;;; !COLD-INIT-FORMS there? (defun !class-finalize () (dohash (name layout *forward-referenced-layouts*)