X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=7d9b77d17950e40832c2b3c0b638a5f85f8dd2de;hb=627c66211b93537e90c08b34b387edbd7e301011;hp=4c67377108aec33f77ae5a14548328faacc39df5;hpb=e240e076bc5bfa07a408a89d2e354e7ec9ff9341;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 4c67377..7d9b77d 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) @@ -410,7 +411,7 @@ (declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid)) check-layout)) (defun check-layout (layout class length inherits depthoid) - (assert (eq (layout-class layout) class)) + (aver (eq (layout-class layout) class)) (when (redefine-layout-warning "current" layout "compile time" length inherits depthoid) ;; Classic CMU CL had more options here. There are several reasons @@ -464,15 +465,15 @@ (class-layout (class-layout class)) (subclasses (class-subclasses class))) - ;; Attempting to register ourselves with a temporary cookie is - ;; almost certainly a programmer error. (I should know, I did it.) - ;; -- WHN 19990927 - (assert (not (undefined-class-p class))) + ;; Attempting to register ourselves with a temporary undefined + ;; class placeholder is almost certainly a programmer error. (I + ;; should know, I did it.) -- WHN 19990927 + (aver (not (undefined-class-p class))) ;; This assertion dates from classic CMU CL. The rationale is ;; probably that calling REGISTER-LAYOUT more than once for the ;; same LAYOUT is almost certainly a programmer error. - (assert (not (eq class-layout layout))) + (aver (not (eq class-layout layout))) ;; Figure out what classes are affected by the change, and issue ;; appropriate warnings and invalidations. @@ -513,7 +514,132 @@ (values)) ); EVAL-WHEN + +;;; Arrange the inherited layouts to appear at their expected depth, +;;; 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)) + (max-depth -1)) + (dotimes (i length) + (let ((depth (layout-depthoid (svref layouts i)))) + (when (> depth max-depth) + (setf max-depth depth)))) + (let* ((new-length (max (1+ max-depth) length)) + (inherits (make-array new-length))) + (dotimes (i length) + (let* ((layout (svref layouts i)) + (depth (layout-depthoid layout))) + (unless (eql depth -1) + (let ((old-layout (svref inherits depth))) + (unless (or (eql old-layout 0) (eq old-layout layout)) + (error "layout depth conflict: ~S~%" layouts))) + (setf (svref inherits depth) layout)))) + (do ((i 0 (1+ i)) + (j 0)) + ((>= i length)) + (declare (type index i j)) + (let* ((layout (svref layouts i)) + (depth (layout-depthoid layout))) + (when (eql depth -1) + (loop (when (eql (svref inherits j) 0) + (return)) + (incf j)) + (setf (svref inherits j) layout)))) + (do ((i (1- new-length) (1- i))) + ((< i 0)) + (declare (type fixnum i)) + (when (eql (svref inherits i) 0) + (setf (svref inherits i) (svref inherits (1+ i))))) + inherits))) + +;;;; class precedence lists + +;;; Topologically sort the list of objects to meet a set of ordering +;;; constraints given by pairs (A . B) constraining A to precede B. +;;; When there are multiple objects to choose, the tie-breaker +;;; function is called with both the list of object to choose from and +;;; the reverse ordering built so far. +(defun topological-sort (objects constraints tie-breaker) + (declare (list objects constraints) + (function tie-breaker)) + (let ((obj-info (make-hash-table :size (length objects))) + (free-objs nil) + (result nil)) + (dolist (constraint constraints) + (let ((obj1 (car constraint)) + (obj2 (cdr constraint))) + (let ((info2 (gethash obj2 obj-info))) + (if info2 + (incf (first info2)) + (setf (gethash obj2 obj-info) (list 1)))) + (let ((info1 (gethash obj1 obj-info))) + (if info1 + (push obj2 (rest info1)) + (setf (gethash obj1 obj-info) (list 0 obj2)))))) + (dolist (obj objects) + (let ((info (gethash obj obj-info))) + (when (or (not info) (zerop (first info))) + (push obj free-objs)))) + (loop + (flet ((next-result (obj) + (push obj result) + (dolist (successor (rest (gethash obj obj-info))) + (let* ((successor-info (gethash successor obj-info)) + (count (1- (first successor-info)))) + (setf (first successor-info) count) + (when (zerop count) + (push successor free-objs)))))) + (cond ((endp free-objs) + (dohash (obj info obj-info) + (unless (zerop (first info)) + (error "Topological sort failed due to constraint on ~S." + obj))) + (return (nreverse result))) + ((endp (rest free-objs)) + (next-result (pop free-objs))) + (t + (let ((obj (funcall tie-breaker free-objs result))) + (setf free-objs (remove obj free-objs)) + (next-result obj)))))))) + + +;;; standard class precedence list computation +(defun std-compute-class-precedence-list (class) + (let ((classes nil) + (constraints nil)) + (labels ((note-class (class) + (unless (member class classes) + (push class classes) + (let ((superclasses (class-direct-superclasses class))) + (do ((prev class) + (rest superclasses (rest rest))) + ((endp rest)) + (let ((next (first rest))) + (push (cons prev next) constraints) + (setf prev next))) + (dolist (class superclasses) + (note-class class))))) + (std-cpl-tie-breaker (free-classes rev-cpl) + (dolist (class rev-cpl (first free-classes)) + (let* ((superclasses (class-direct-superclasses class)) + (intersection (intersection free-classes + superclasses))) + (when intersection + (return (first intersection))))))) + (note-class class) + (topological-sort classes constraints #'std-cpl-tie-breaker)))) +;;;; object types to represent classes + ;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward ;;; referenced layouts. Users should never see them. (def!struct (undefined-class (:include #-sb-xc sb!xc:class @@ -539,7 +665,7 @@ (translation nil :type (or ctype (member nil :initializing)))) (defun make-built-in-class (&rest rest) (apply #'bare-make-built-in-class - (rename-keyword-args '((:name :%name)) rest))) + (rename-key-args '((:name :%name)) rest))) ;;; FIXME: In CMU CL, this was a class with a print function, but not ;;; necessarily a structure class (e.g. CONDITIONs). In SBCL, @@ -560,7 +686,7 @@ (constructor nil :type (or function null))) (defun make-structure-class (&rest rest) (apply #'bare-make-structure-class - (rename-keyword-args '((:name :%name)) rest))) + (rename-key-args '((:name :%name)) rest))) ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable ;;; structures, which are used to implement generic functions. @@ -568,7 +694,7 @@ (:constructor bare-make-funcallable-structure-class))) (defun make-funcallable-structure-class (&rest rest) (apply #'bare-make-funcallable-structure-class - (rename-keyword-args '((:name :%name)) rest))) + (rename-key-args '((:name :%name)) rest))) ;;;; class namespace @@ -609,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))) @@ -638,7 +768,7 @@ ;;; always of the desired class. The second result is any existing ;;; LAYOUT for this name. (defun insured-find-class (name predicate constructor) - (declare (function predicate constructor)) + (declare (type function predicate constructor)) (let* ((old (sb!xc:find-class name nil)) (res (if (and old (funcall predicate old)) old @@ -660,17 +790,17 @@ ;;;; CLASS type operations -(define-type-class sb!xc:class) +(!define-type-class sb!xc:class) ;;; 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 (sb!xc:class :simple-=) (type1 type2) - (assert (not (eq type1 type2))) +(!define-type-method (sb!xc:class :simple-=) (type1 type2) + (aver (not (eq type1 type2))) (values nil t)) -(define-type-method (sb!xc:class :simple-subtypep) (class1 class2) - (assert (not (eq class1 class2))) +(!define-type-method (sb!xc:class :simple-subtypep) (class1 class2) + (aver (not (eq class1 class2))) (let ((subclasses (class-subclasses class2))) (if (and subclasses (gethash class1 subclasses)) (values t t) @@ -679,7 +809,7 @@ ;;; When finding the intersection of a sealed class and some other ;;; class (not hierarchically related) the intersection is the union ;;; of the currently shared subclasses. -(defun sealed-class-intersection (sealed other) +(defun sealed-class-intersection2 (sealed other) (declare (type sb!xc:class sealed other)) (let ((s-sub (class-subclasses sealed)) (o-sub (class-subclasses other))) @@ -689,34 +819,39 @@ (declare (ignore layout)) (when (gethash subclass o-sub) (res (specifier-type subclass)))) - (values (res) t)) - (values *empty-type* t)))) + (res)) + *empty-type*))) -;;; If one is a subclass of the other, then that is the intersection, -;;; but we can only be sure the intersection is otherwise empty if -;;; they are structure classes, since a subclass of both might be -;;; defined. If either class is sealed, we can eliminate this -;;; possibility. -(define-type-method (sb!xc:class :simple-intersection) (class1 class2) +(!define-type-method (sb!xc:class :simple-intersection2) (class1 class2) (declare (type sb!xc:class class1 class2)) - (cond ((eq class1 class2) class1) + (cond ((eq class1 class2) + class1) + ;; If one is a subclass of the other, then that is the + ;; intersection. ((let ((subclasses (class-subclasses class2))) (and subclasses (gethash class1 subclasses))) - (values class1 t)) + class1) ((let ((subclasses (class-subclasses class1))) (and subclasses (gethash class2 subclasses))) - (values class2 t)) + class2) + ;; 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-class-p class1) (basic-structure-class-p class2)) - (values *empty-type* t)) + ;; No subclass of both can be defined. + *empty-type*) ((eq (class-state class1) :sealed) - (sealed-class-intersection class1 class2)) + ;; checking whether a subclass of both can be defined: + (sealed-class-intersection2 class1 class2)) ((eq (class-state class2) :sealed) - (sealed-class-intersection class2 class1)) + ;; checking whether a subclass of both can be defined: + (sealed-class-intersection2 class2 class1)) (t - (values class1 nil)))) + ;; uncertain, since a subclass of both might be defined + nil))) -(define-type-method (sb!xc:class :unparse) (type) +(!define-type-method (sb!xc:class :unparse) (type) (class-proper-name type)) ;;;; PCL stuff @@ -729,10 +864,10 @@ (:constructor bare-make-random-pcl-class))) (defun make-standard-class (&rest rest) (apply #'bare-make-standard-class - (rename-keyword-args '((:name :%name)) rest))) + (rename-key-args '((:name :%name)) rest))) (defun make-random-pcl-class (&rest rest) (apply #'bare-make-random-pcl-class - (rename-keyword-args '((:name :%name)) rest))) + (rename-key-args '((:name :%name)) rest))) ;;;; built-in classes @@ -782,297 +917,211 @@ (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.. - (collection :hierarchical-p nil :state :read-only) - (mutable-collection :state :read-only - :inherits (collection)) - (generic-sequence :state :read-only - :inherits (collection)) - (mutable-sequence :state :read-only - :direct-superclasses (mutable-collection - generic-sequence) - :inherits (mutable-collection - generic-sequence - collection)) - (generic-array :state :read-only - :inherits (mutable-sequence - mutable-collection - generic-sequence - collection)) - (generic-vector :state :read-only - :inherits (generic-array - mutable-sequence mutable-collection - generic-sequence collection)) - (array :translation array :codes (#.sb!vm:complex-array-type) - :inherits (generic-array mutable-sequence mutable-collection - generic-sequence collection)) + (array :translation array :codes (#.sb!vm:complex-array-widetag) + :hierarchical-p nil) (simple-array - :translation simple-array :codes (#.sb!vm:simple-array-type) - :inherits (array generic-array mutable-sequence mutable-collection - generic-sequence collection)) + :translation simple-array :codes (#.sb!vm:simple-array-widetag) + :inherits (array)) (sequence - :translation (or cons (member nil) vector) - :inherits (mutable-sequence mutable-collection generic-sequence - collection)) + :translation (or cons (member nil) vector)) (vector - :translation vector :codes (#.sb!vm:complex-vector-type) - :direct-superclasses (array sequence generic-vector) - :inherits (array sequence generic-vector generic-array - mutable-sequence mutable-collection generic-sequence - collection)) + :translation vector :codes (#.sb!vm:complex-vector-widetag) + :direct-superclasses (array sequence) + :inherits (array sequence)) (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)) + :inherits (vector simple-array array sequence)) (bit-vector - :translation bit-vector :codes (#.sb!vm:complex-bit-vector-type) - :inherits (vector array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) + :inherits (vector array sequence)) (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 - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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 - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) #!+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)) + :inherits (vector simple-array array sequence)) (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)) + :inherits (vector simple-array array sequence)) (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 - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) #!+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 - mutable-collection generic-sequence collection)) - (generic-string - :state :read-only - :inherits (mutable-sequence mutable-collection generic-sequence - collection)) + :inherits (vector simple-array array sequence)) (string :translation string - :codes (#.sb!vm:complex-string-type) - :direct-superclasses (vector generic-string) - :inherits (vector array sequence - generic-vector generic-array generic-string - mutable-sequence mutable-collection - generic-sequence collection)) + :codes (#.sb!vm:complex-string-widetag) + :direct-superclasses (vector) + :inherits (vector array sequence)) (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 - generic-string generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) - (generic-number :state :read-only) - (number :translation number :inherits (generic-number)) + array sequence)) + (list + :translation (or cons (member nil)) + :inherits (sequence)) + (cons + :codes (#.sb!vm:list-pointer-lowtag) + :translation cons + :inherits (list sequence)) + (null + :translation (member nil) + :inherits (symbol list sequence) + :direct-superclasses (symbol list)) + (number :translation number) (complex :translation complex - :inherits (number generic-number) - :codes (#.sb!vm:complex-type)) + :inherits (number) + :codes (#.sb!vm:complex-widetag)) (complex-single-float :translation (complex single-float) - :inherits (complex number generic-number) - :codes (#.sb!vm:complex-single-float-type)) + :inherits (complex number) + :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)) + :inherits (complex number) + :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)) - (real :translation real :inherits (number generic-number)) + :inherits (complex number) + :codes (#.sb!vm:complex-long-float-widetag)) + (real :translation real :inherits (number)) (float :translation float - :inherits (real number generic-number)) + :inherits (real number)) (single-float :translation single-float - :inherits (float real number generic-number) - :codes (#.sb!vm:single-float-type)) + :inherits (float real number) + :codes (#.sb!vm:single-float-widetag)) (double-float :translation double-float - :inherits (float real number generic-number) - :codes (#.sb!vm:double-float-type)) + :inherits (float real number) + :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)) + :inherits (float real number) + :codes (#.sb!vm:long-float-widetag)) (rational :translation rational - :inherits (real number generic-number)) + :inherits (real number)) (ratio :translation (and rational (not integer)) - :inherits (rational real number generic-number) - :codes (#.sb!vm:ratio-type)) + :inherits (rational real number) + :codes (#.sb!vm:ratio-widetag)) (integer :translation integer - :inherits (rational real number generic-number)) + :inherits (rational real number)) (fixnum - :translation (integer #.sb!vm:*target-most-negative-fixnum* - #.sb!vm:*target-most-positive-fixnum*) - :inherits (integer rational real number - generic-number) - :codes (#.sb!vm:even-fixnum-type #.sb!vm:odd-fixnum-type)) + :translation (integer #.sb!xc:most-negative-fixnum + #.sb!xc:most-positive-fixnum) + :inherits (integer rational real number) + :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)) - - (list - :translation (or cons (member nil)) - :inherits (sequence mutable-sequence mutable-collection - generic-sequence collection)) - (cons - :codes (#.sb!vm:list-pointer-type) - :translation cons - :inherits (list sequence - mutable-sequence mutable-collection - generic-sequence collection)) - (null - :translation (member nil) - :inherits (list sequence - mutable-sequence mutable-collection - generic-sequence collection symbol) - :direct-superclasses (list symbol)) + :inherits (integer rational real number) + :codes (#.sb!vm:bignum-widetag)) (stream - :hierarchical-p nil :state :read-only - :inherits (instance t))))) + :depth 3 + :inherits (instance))))) ;;; comment from CMU CL: ;;; See also type-init.lisp where we finish setting up the ;;; translations for built-in types. (!cold-init-forms - #-sb-xc-host (/show0 "about to loop over *BUILT-IN-CLASSES*") (dolist (x *built-in-classes*) #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*") (destructuring-bind @@ -1082,29 +1131,30 @@ codes enumerable state + depth (hierarchical-p t) ; might be modified below (direct-superclasses (if inherits (list (car inherits)) '(t)))) x (declare (ignore codes state translation)) - (let ((inherits-list (if (eq name 't) - () - (cons 't (reverse inherits)))) + (let ((inherits-list (if (eq name t) + () + (cons t (reverse inherits)))) (class (make-built-in-class :enumerable enumerable :name name :translation (if trans-p :initializing nil) :direct-superclasses - (if (eq name 't) + (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)) (let* ((inherits-vector - (map 'vector + (map 'simple-vector (lambda (x) (let ((super-layout (class-layout (sb!xc:find-class x)))) @@ -1112,33 +1162,60 @@ (setf hierarchical-p nil)) super-layout)) inherits-list)) - (depthoid (if hierarchical-p (length inherits-vector) -1))) + (depthoid (if hierarchical-p + (or depth (length inherits-vector)) + -1))) (register-layout (find-and-init-or-check-layout name 0 inherits-vector depthoid) :invalidate nil))))) - #-sb-xc-host (/show0 "done with loop over *BUILT-IN-CLASSES*")) + (/show0 "done with loop over *BUILT-IN-CLASSES*")) ;;; Define temporary PCL STANDARD-CLASSes. These will be set up -;;; correctly and the lisp layout replaced by a PCL wrapper after PCL +;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL ;;; is loaded and the class defined. (!cold-init-forms - (dolist (x '((fundamental-stream (t instance stream)))) + (/show0 "about to define temporary STANDARD-CLASSes") + (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)) (inherits-list (second x)) (class (make-standard-class :name name)) (class-cell (find-class-cell name))) + ;; Needed to open-code the MAP, below + (declare (type list inherits-list)) (setf (class-cell-class class-cell) class (info :type :class name) class-cell (info :type :kind name) :instance) - (let ((inherits (map 'vector + (let ((inherits (map 'simple-vector (lambda (x) (class-layout (sb!xc:find-class x))) inherits-list))) + #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits) (register-layout (find-and-init-or-check-layout name 0 inherits -1) - :invalidate nil))))) + :invalidate nil)))) + (/show0 "done defining temporary STANDARD-CLASSes")) ;;; Now that we have set up the class heterarchy, seal the sealed ;;; classes. This must be done after the subclasses have been set up. @@ -1182,7 +1259,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*)