(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
;; * 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
(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
(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)
;; Attempting to register ourselves with a temporary undefined
;; class placeholder is almost certainly a programmer error. (I
;; should know, I did it.) -- WHN 19990927
- (assert (not (undefined-class-p class)))
+ (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.
(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)))
+\f
+;;;; 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))))
\f
+;;;; 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
(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,
(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.
(: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)))
\f
;;;; class namespace
;;; 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
;;; 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)))
+ (aver (not (eq type1 type2)))
(values nil t))
(!define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
- (assert (not (eq class1 class2)))
+ (aver (not (eq class1 class2)))
(let ((subclasses (class-subclasses class2)))
(if (and subclasses (gethash class1 subclasses))
(values t t)
;;; 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)))
(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)
(class-proper-name type))
(: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)))
\f
;;;; built-in classes
(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)
: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
: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
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
#!+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
#!+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
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
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
generic-string generic-vector generic-array mutable-sequence
mutable-collection generic-sequence collection))
+ (list
+ :translation (or cons (member nil))
+ :inherits (sequence mutable-sequence mutable-collection
+ generic-sequence collection))
+ (cons
+ :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
+ mutable-sequence mutable-collection
+ generic-sequence collection symbol)
+ :direct-superclasses (list symbol))
(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
(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))
#.sb!vm:*target-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))
-
- (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))
+ :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
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
(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))))
(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))
(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.
;;; 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*)