;;;; This file contains structures and functions for the maintenance of ;;;; basic information about defined types. Different object systems ;;;; can be supported simultaneously. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!KERNEL") (!begin-collecting-cold-init-forms) ;;;; the CLASSOID structure ;;; The CLASSOID structure is a supertype of all classoid types. A ;;; CLASSOID is also a CTYPE structure as recognized by the type ;;; system. (FIXME: It's also a type specifier, though this might go ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no ;;; longer necessary) (def!struct (classoid (:make-load-form-fun classoid-make-load-form-fun) (:include ctype (class-info (type-class-or-lose 'classoid))) (:constructor nil) #-no-ansi-print-object (:print-object (lambda (class stream) (let ((name (classoid-name class))) (print-unreadable-object (class stream :type t :identity (not name)) (format stream ;; FIXME: Make sure that this prints ;; reasonably for anonymous classes. "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]" name (classoid-state class)))))) #-sb-xc-host (:pure nil)) ;; the value to be returned by CLASSOID-NAME. (name nil :type symbol) ;; the current layout for this class, or NIL if none assigned yet (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. ;; :SEALED = We can't even add subclasses. ;; NIL = Anything could happen. (state nil :type (member nil :read-only :sealed)) ;; direct superclasses of this class. Always NIL for CLOS classes. (direct-superclasses () :type list) ;; representation of all of the subclasses (direct or indirect) of ;; this class. This is NIL if no subclasses or not initalized yet; ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the ;; subclass layout that was in effect at the time the subclass was ;; created. (subclasses nil :type (or null hash-table)) ;; the PCL class (= CL:CLASS, but with a view to future flexibility ;; we don't just call it the CLASS slot) object for this class, or ;; NIL if none assigned yet (pcl-class nil)) (defun classoid-make-load-form-fun (class) (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class) (let ((name (classoid-name class))) (unless (and name (eq (find-classoid name nil) class)) (/show "anonymous/undefined class case") (error "can't use anonymous or undefined class as constant:~% ~S" class)) `(locally ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant ;; class names which creates fast but non-cold-loadable, ;; non-compact code. In this context, we'd rather have compact, ;; cold-loadable code. -- WHN 19990928 (declare (notinline find-classoid)) (find-classoid ',name)))) ;;;; basic LAYOUT stuff ;;; 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. (def!constant layout-clos-hash-limit (1+ (ash sb!xc:most-positive-fixnum -3)) #!+sb-doc "the exclusive upper bound on LAYOUT-CLOS-HASH values") (def!type layout-clos-hash () '(integer 0 #.layout-clos-hash-limit)) ;;; a list of conses, initialized by genesis ;;; ;;; In each cons, the car is the symbol naming the layout, and the ;;; cdr is the layout itself. (defvar *!initial-layouts*) ;;; a table mapping class names to layouts for classes we have ;;; referenced but not yet loaded. This is initialized from an alist ;;; created by genesis describing the layouts that genesis created at ;;; cold-load time. (defvar *forward-referenced-layouts*) (!cold-init-forms ;; Protected by *WORLD-LOCK* (setq *forward-referenced-layouts* (make-hash-table :test 'equal)) #-sb-xc-host (progn (/show0 "processing *!INITIAL-LAYOUTS*") (dolist (x *!initial-layouts*) (setf (layout-clos-hash (cdr x)) (random-layout-clos-hash)) (setf (gethash (car x) *forward-referenced-layouts*) (cdr x))) (/show0 "done processing *!INITIAL-LAYOUTS*"))) ;;; The LAYOUT structure is pointed to by the first cell of instance ;;; (or structure) objects. It represents what we need to know for ;;; type checking and garbage collection. Whenever a class is ;;; incompatibly redefined, a new layout is allocated. If two object's ;;; layouts are EQ, then they are exactly the same type. ;;; ;;; *** IMPORTANT *** ;;; ;;; If you change the slots of LAYOUT, you need to alter genesis as ;;; well, since the initialization of layout slots is hardcoded there. ;;; ;;; FIXME: ...it would be better to automate this, of course... (def!struct (layout ;; KLUDGE: A special hack keeps this from being ;; called when building code for the ;; cross-compiler. See comments at the DEFUN for ;; this. -- WHN 19990914 (:make-load-form-fun #-sb-xc-host ignore-it ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST ;; time controls both the ;; build-the-cross-compiler behavior ;; and the run-the-cross-compiler ;; behavior. The value below only ;; works for build-the-cross-compiler. ;; There's a special hack in ;; EMIT-MAKE-LOAD-FORM which gives ;; effectively IGNORE-IT behavior for ;; LAYOUT at run-the-cross-compiler ;; time. It would be cleaner to ;; actually have an IGNORE-IT value ;; stored, but it's hard to see how to ;; do that concisely with the current ;; DEF!STRUCT setup. -- WHN 19990930 #+sb-xc-host make-load-form-for-layout)) ;; a pseudo-random hash value for use by CLOS. KLUDGE: The fact ;; that this slot is at offset 1 is known to GENESIS. (clos-hash (random-layout-clos-hash) :type layout-clos-hash) ;; the class that this is a layout for (classoid (missing-arg) :type classoid) ;; 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 ;; a new, more-up-to-date LAYOUT). ;; * 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, i.e. if ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS ;; (least to most specific), so that each inherited layout appears ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value. ;; ;; 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 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 ;; comparing deepness; it is generally useful to do a bare numeric ;; comparison of these depthoid values, and we hardly ever need to ;; test whether the values are negative or not. ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was ;; 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 (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. (info nil) ;; This is true if objects of this class are never modified to ;; contain dynamic pointers in their slots or constant-like ;; substructure (and hence can be copied into read-only space by ;; PURIFY). ;; ;; This slot is known to the C runtime support code. (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) ;; Definition location (source-location nil) ;; Information about slots in the class to PCL: this provides fast ;; access to slot-definitions and locations by name, etc. (slot-table #(nil) :type simple-vector) ;; True IFF the layout belongs to a standand-instance or a ;; standard-funcallable-instance -- that is, true only if the layout ;; is really a wrapper. ;; ;; FIXME: If we unify wrappers and layouts this can go away, since ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot ;; layouts, there are no slots for it to pull.) (for-std-class-p nil :type boolean :read-only t)) (def!method print-object ((layout layout) stream) (print-unreadable-object (layout stream :type t :identity t) (format stream "for ~S~@[, INVALID=~S~]" (layout-proper-name layout) (layout-invalid layout)))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun layout-proper-name (layout) (classoid-proper-name (layout-classoid layout)))) ;;;; support for the hash values used by CLOS when working with LAYOUTs ;;; a generator for random values suitable for the CLOS-HASH slots of ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like ;;; pseudo-random values to come the same way in the target even when ;;; we make minor changes to the system, in order to reduce the ;;; mysteriousness of possible CLOS bugs. (defvar *layout-clos-hash-random-state*) (defun random-layout-clos-hash () ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)), ;; returning a strictly positive value. I copied it verbatim from ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I ;; dunno whether the hash values are really supposed to be 1-based. ;; 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 (1- layout-clos-hash-limit) (if (boundp '*layout-clos-hash-random-state*) *layout-clos-hash-random-state* (setf *layout-clos-hash-random-state* (make-random-state)))))) ;;; If we can't find any existing layout, then we create a new one ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we ;;; used to immediately check for compatibility, but for ;;; cross-compilability reasons (i.e. convenience of using this ;;; function in a MAKE-LOAD-FORM expression) that functionality has ;;; been split off into INIT-OR-CHECK-LAYOUT. (declaim (ftype (sfunction (symbol) layout) find-layout)) (defun find-layout (name) ;; This seems to be currently used only from the compiler, but make ;; it thread-safe all the same. We need to lock *F-R-L* before doing ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel. (let ((table *forward-referenced-layouts*)) (with-world-lock () (let ((classoid (find-classoid name nil))) (or (and classoid (classoid-layout classoid)) (gethash name table) (setf (gethash name table) (make-layout :classoid (or classoid (make-undefined-classoid name))))))))) ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH, ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent ;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID. ;;; ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know ;;; anything about the class", so if LAYOUT is initialized, any ;;; preexisting class slot value is OK, and if it's not initialized, ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This ;;; is no longer true, :UNINITIALIZED used instead. (declaim (ftype (function (layout classoid index simple-vector layout-depthoid index) layout) %init-or-check-layout)) (defun %init-or-check-layout (layout classoid length inherits depthoid nuntagged) (cond ((eq (layout-invalid layout) :uninitialized) ;; There was no layout before, we just created one which ;; we'll now initialize with our information. (setf (layout-length layout) length (layout-inherits layout) inherits (layout-depthoid layout) depthoid (layout-n-untagged-slots layout) nuntagged (layout-classoid layout) classoid (layout-invalid layout) nil)) ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this ;; clause is not needed? ((not *type-system-initialized*) (setf (layout-classoid layout) classoid)) (t ;; There was an old layout already initialized with old ;; information, and we'll now check that old information ;; which was known with certainty is consistent with current ;; information which is known with certainty. (check-layout layout classoid length inherits depthoid nuntagged))) layout) ;;; In code for the target Lisp, we don't use dump LAYOUTs using the ;;; standard load form mechanism, we use special fops instead, in ;;; order to make cold load come out right. But when we're building ;;; the cross-compiler, we can't do that because we don't have access ;;; to special non-ANSI low-level things like special fops, and we ;;; don't need to do that anyway because our code isn't going to be ;;; cold loaded, so we use the ordinary load form system. ;;; ;;; KLUDGE: A special hack causes this not to be called when we are ;;; building code for the target Lisp. It would be tidier to just not ;;; have it in place when we're building the target Lisp, but it ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a ;;; bit, so I punted. -- WHN 19990914 #+sb-xc-host (defun make-load-form-for-layout (layout &optional env) (declare (type layout layout)) (declare (ignore env)) (when (layout-invalid layout) (compiler-error "can't dump reference to obsolete class: ~S" (layout-classoid layout))) (let ((name (classoid-name (layout-classoid layout)))) (unless name (compiler-error "can't dump anonymous LAYOUT: ~S" layout)) ;; Since LAYOUT refers to a class which refers back to the LAYOUT, ;; we have to do this in two stages, like the TREE-WITH-PARENT ;; example in the MAKE-LOAD-FORM entry in the ANSI spec. (values ;; "creation" form (which actually doesn't create a new LAYOUT if ;; there's a preexisting one with this name) `(find-layout ',name) ;; "initialization" form (which actually doesn't initialize ;; preexisting LAYOUTs, just checks that they're consistent). `(%init-or-check-layout ',layout ',(layout-classoid layout) ',(layout-length layout) ',(layout-inherits layout) ',(layout-depthoid layout) ',(layout-n-untagged-slots layout))))) ;;; If LAYOUT's slot values differ from the specified slot values in ;;; any interesting way, then give a warning and return T. (declaim (ftype (function (simple-string layout simple-string index simple-vector layout-depthoid index)) redefine-layout-warning)) (defun redefine-layout-warning (old-context old-layout context length inherits depthoid nuntagged) (declare (type layout old-layout) (type simple-string old-context context)) (let ((name (layout-proper-name old-layout))) (or (let ((old-inherits (layout-inherits old-layout))) (or (when (mismatch old-inherits inherits :key #'layout-proper-name) (warn "change in superclasses of class ~S:~% ~ ~A superclasses: ~S~% ~ ~A superclasses: ~S" name old-context (map 'list #'layout-proper-name old-inherits) context (map 'list #'layout-proper-name inherits)) t) (let ((diff (mismatch old-inherits inherits))) (when diff (warn "in class ~S:~% ~ ~@(~A~) definition of superclass ~S is incompatible with~% ~ ~A definition." name old-context (layout-proper-name (svref old-inherits diff)) context) t)))) (let ((old-length (layout-length old-layout))) (unless (= old-length length) (warn "change in instance length of class ~S:~% ~ ~A length: ~W~% ~ ~A length: ~W" name old-context old-length context length) t)) (let ((old-nuntagged (layout-n-untagged-slots old-layout))) (unless (= old-nuntagged nuntagged) (warn "change in instance layout of class ~S:~% ~ ~A untagged slots: ~W~% ~ ~A untagged slots: ~W" name old-context old-nuntagged context nuntagged) t)) (unless (= (layout-depthoid old-layout) depthoid) (warn "change in the inheritance structure of class ~S~% ~ between the ~A definition and the ~A definition" name old-context context) t)))) ;;; Require that LAYOUT data be consistent with CLASS, LENGTH, ;;; INHERITS, and DEPTHOID. (declaim (ftype (function (layout classoid index simple-vector layout-depthoid index)) check-layout)) (defun check-layout (layout classoid length inherits depthoid nuntagged) (aver (eq (layout-classoid layout) classoid)) (when (redefine-layout-warning "current" layout "compile time" length inherits depthoid nuntagged) ;; Classic CMU CL had more options here. There are several reasons ;; why they might want more options which are less appropriate for ;; us: (1) It's hard to fit the classic CMU CL flexible approach ;; into the ANSI-style MAKE-LOAD-FORM system, and having a ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2) ;; We have CLOS now, and if you want to be able to flexibly ;; redefine classes without restarting the system, it'd make sense ;; to use that, so supporting complexity in order to allow ;; modifying DEFSTRUCTs without restarting the system is a low ;; priority. (3) We now have the ability to rebuild the SBCL ;; system from scratch, so we no longer need this functionality in ;; order to maintain the SBCL system by modifying running images. (error "The loaded code expects an incompatible layout for class ~S." (layout-proper-name layout))) (values)) ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a ;;; single function call ;;; ;;; Used by the loader to forward-reference layouts for classes whose ;;; definitions may not have been loaded yet. This allows type tests ;;; to be loaded when the type definition hasn't been loaded yet. (declaim (ftype (function (symbol index simple-vector layout-depthoid index) layout) find-and-init-or-check-layout)) (defun find-and-init-or-check-layout (name length inherits depthoid nuntagged) (with-world-lock () (let ((layout (find-layout name))) (%init-or-check-layout layout (or (find-classoid name nil) (layout-classoid layout)) length inherits depthoid nuntagged)))) ;;; Record LAYOUT as the layout for its class, adding it as a subtype ;;; of all superclasses. This is the operation that "installs" a ;;; layout for a class in the type system, clobbering any old layout. ;;; However, this does not modify the class namespace; that is a ;;; separate operation (think anonymous classes.) ;;; -- If INVALIDATE, then all the layouts for any old definition ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared. ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be ;;; destructively modified to hold the same type information. (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun register-layout (layout &key (invalidate t) destruct-layout) (declare (type layout layout) (type (or layout null) destruct-layout)) (with-world-lock () (let* ((classoid (layout-classoid layout)) (classoid-layout (classoid-layout classoid)) (subclasses (classoid-subclasses classoid))) ;; 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-classoid-p classoid))) ;; 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. (aver (not (eq classoid-layout layout))) ;; Figure out what classes are affected by the change, and issue ;; appropriate warnings and invalidations. (when classoid-layout (%modify-classoid classoid) (when subclasses (dohash ((subclass subclass-layout) subclasses :locked t) (%modify-classoid subclass) (when invalidate (%invalidate-layout subclass-layout)))) (when invalidate (%invalidate-layout classoid-layout) (setf (classoid-subclasses classoid) nil))) (if destruct-layout (setf (layout-invalid destruct-layout) nil (layout-inherits destruct-layout) (layout-inherits layout) (layout-depthoid destruct-layout)(layout-depthoid layout) (layout-length destruct-layout) (layout-length layout) (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout) (layout-info destruct-layout) (layout-info layout) (classoid-layout classoid) destruct-layout) (setf (layout-invalid layout) nil (classoid-layout classoid) layout)) (dovector (super-layout (layout-inherits layout)) (let* ((super (layout-classoid super-layout)) (subclasses (or (classoid-subclasses super) (setf (classoid-subclasses super) (make-hash-table :test 'eq #-sb-xc-host #-sb-xc-host :synchronized t))))) (when (and (eq (classoid-state super) :sealed) (not (gethash classoid subclasses))) (warn "unsealing sealed class ~S in order to subclass it" (classoid-name super)) (setf (classoid-state super) :read-only)) (setf (gethash classoid subclasses) (or destruct-layout layout)))))) (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)) ;; KLUDGE: 0 here is the "uninitialized" element. We need ;; to specify it explicitly for portability purposes, as ;; elements can be read before being set [ see below, "(EQL ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20 (inherits (make-array new-length :initial-element 0))) (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 (classoid-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 (classoid-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-CLASSOID is a cookie we make up to stick in forward ;;; referenced layouts. Users should never see them. (def!struct (undefined-classoid (:include classoid) (:constructor make-undefined-classoid (name)))) ;;; BUILT-IN-CLASS is used to represent the standard classes that ;;; aren't defined with DEFSTRUCT and other specially implemented ;;; primitive types whose only attribute is their name. ;;; ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they ;;; are effectively DEFTYPE'd to some other type (usually a union of ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.) ;;; This translation is done when type specifiers are parsed. Type ;;; system operations (union, subtypep, etc.) should never encounter ;;; translated classes, only their translation. (def!struct (built-in-classoid (:include classoid) (:constructor make-built-in-classoid)) ;; the type we translate to on parsing. If NIL, then this class ;; stands on its own; or it can be set to :INITIALIZING for a period ;; during cold-load. (translation nil :type (or ctype (member nil :initializing)))) ;;; 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 (structure-classoid (:include classoid) (:constructor make-structure-classoid)) ;; If true, a default keyword constructor for this structure. (constructor nil :type (or function null))) ;;;; classoid namespace ;;; We use an indirection to allow forward referencing of class ;;; definitions with load-time resolution. (def!struct (classoid-cell (:constructor make-classoid-cell (name &optional classoid)) (:make-load-form-fun (lambda (c) `(find-classoid-cell ',(classoid-cell-name c) :errorp t))) #-no-ansi-print-object (:print-object (lambda (s stream) (print-unreadable-object (s stream :type t) (prin1 (classoid-cell-name s) stream))))) ;; Name of class we expect to find. (name nil :type symbol :read-only t) ;; Classoid or NIL if not yet defined. (classoid nil :type (or classoid null)) ;; PCL class, if any (pcl-class nil)) ;;; Protected by the hash-table lock, used only in FIND-CLASSOID-CELL. (defvar *classoid-cells*) (!cold-init-forms (setq *classoid-cells* (make-hash-table :test 'eq))) (defun find-classoid-cell (name &key create errorp) (let ((table *classoid-cells*) (real-name (uncross name))) (or (with-locked-system-table (table) (or (gethash real-name table) (when create (setf (gethash real-name table) (make-classoid-cell real-name))))) (when errorp (error 'simple-type-error :datum nil :expected-type 'class :format-control "Class not yet defined: ~S" :format-arguments (list name)))))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;; Return the classoid with the specified NAME. If ERRORP is false, ;; then NIL is returned when no such class exists." (defun find-classoid (name &optional (errorp t)) (declare (type symbol name)) (let ((cell (find-classoid-cell name :errorp errorp))) (when cell (classoid-cell-classoid cell)))) (defun (setf find-classoid) (new-value name) #-sb-xc (declare (type (or null classoid) new-value)) (aver new-value) (let ((table *forward-referenced-layouts*)) (with-world-lock () (let ((cell (find-classoid-cell name :create t))) (ecase (info :type :kind name) ((nil)) (:forthcoming-defclass-type ;; FIXME: Currently, nothing needs to be done in this case. ;; Later, when PCL is integrated tighter into SBCL, this ;; might need more work. nil) (:instance (aver cell) (let ((old-value (classoid-cell-classoid cell))) (aver old-value) ;; KLUDGE: The reason these clauses aren't directly ;; parallel is that we need to use the internal ;; CLASSOID structure ourselves, because we don't ;; have CLASSes to work with until PCL is built. In ;; the host, CLASSes have an approximately ;; one-to-one correspondence with the target ;; CLASSOIDs (as well as with the target CLASSes, ;; modulo potential differences with respect to ;; conditions). #+sb-xc-host (let ((old (class-of old-value)) (new (class-of new-value))) (unless (eq old new) (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~ cross-compiler." name (class-name old) (class-name new)))) #-sb-xc-host (let ((old (classoid-of old-value)) (new (classoid-of new-value))) (unless (eq old new) (warn "Changing meta-class of ~S from ~S to ~S." name (classoid-name old) (classoid-name new)))))) (:primitive (error "Cannot redefine standard type ~S." name)) (:defined (warn "redefining DEFTYPE type to be a class: ~ ~/sb-impl::print-symbol-with-prefix/" name) (setf (info :type :expander name) nil (info :type :lambda-list name) nil (info :type :source-location name) nil))) (remhash name table) (%note-type-defined name) ;; 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 cell) new-value) (unless (eq (info :type :compiler-layout name) (classoid-layout new-value)) (setf (info :type :compiler-layout name) (classoid-layout new-value)))))) new-value) (defun %clear-classoid (name cell) (ecase (info :type :kind name) ((nil)) (:defined) (:primitive (error "Attempt to remove :PRIMITIVE type: ~S" name)) ((:forthcoming-defclass-type :instance) (when cell ;; Note: We cannot remove the classoid cell from the table, ;; since compiled code may refer directly to the cell, and ;; getting a different cell for a classoid with the same name ;; just would not do. ;; Remove the proper name of the classoid. (setf (classoid-name (classoid-cell-classoid cell)) nil) ;; Clear the cell. (setf (classoid-cell-classoid cell) nil (classoid-cell-pcl-class cell) nil)) (setf (info :type :kind name) nil (info :type :documentation name) nil (info :type :compiler-layout name) nil))))) ;;; Called when we are about to define NAME as a class meeting some ;;; predicate (such as a meta-class type test.) The first result is ;;; always of the desired class. The second result is any existing ;;; LAYOUT for this name. ;;; ;;; Again, this should be compiler-only, but easier to make this ;;; thread-safe. (defun insured-find-classoid (name predicate constructor) (declare (type function predicate constructor)) (let ((table *forward-referenced-layouts*)) (with-locked-system-table (table) (let* ((old (find-classoid name nil)) (res (if (and old (funcall predicate old)) old (funcall constructor :name name))) (found (or (gethash name table) (when old (classoid-layout old))))) (when found (setf (layout-classoid found) res)) (values res found))))) ;;; If the classoid has a proper name, return the name, otherwise return ;;; the classoid. (defun classoid-proper-name (classoid) #-sb-xc (declare (type classoid classoid)) (let ((name (classoid-name classoid))) (if (and name (eq (find-classoid name nil) classoid)) name classoid))) ;;;; CLASS type operations (!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 error-context) (aver (eq classoid (layout-classoid layout))) (or (not (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) t) ((sb!pcl::class-has-a-forward-referenced-superclass-p class) (when error-context (bug "~@" class (sb!pcl::class-has-a-forward-referenced-superclass-p class) error-context)) nil) (t (sb!pcl:finalize-inheritance class) t))) (bug "~@" classoid (or error-context 'subtypep))))) (defun %ensure-both-classoids-valid (class1 class2 &optional errorp) (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))) t) (aver (< i 2)) (unless (and (%ensure-classoid-valid class1 layout1 errorp) (%ensure-classoid-valid class2 layout2 errorp)) (return-from %ensure-both-classoids-valid nil)))) (defun update-object-layout-or-invalid (object layout) (if (layout-for-std-class-p (layout-of object)) (sb!pcl::check-wrapper-validity object) (sb!c::%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. (!define-type-method (classoid :simple-=) (type1 type2) (aver (not (eq type1 type2))) (values nil t)) (!define-type-method (classoid :simple-subtypep) (class1 class2) (aver (not (eq class1 class2))) (with-world-lock () (if (%ensure-both-classoids-valid class1 class2) (let ((subclasses2 (classoid-subclasses class2))) (if (and subclasses2 (gethash class1 subclasses2)) (values t t) (if (and (typep class1 'standard-classoid) (typep class2 'standard-classoid) (or (sb!pcl::class-has-a-forward-referenced-superclass-p (classoid-pcl-class class1)) (sb!pcl::class-has-a-forward-referenced-superclass-p (classoid-pcl-class class2)))) ;; If there's a forward-referenced class involved we don't know for sure. ;; (There are cases which we /could/ figure out, but that doesn't seem ;; to be required or important, really.) (values nil nil) (values nil t)))) (values nil nil)))) ;;; 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-intersection2 (sealed other) (declare (type classoid sealed other)) (let ((s-sub (classoid-subclasses sealed)) (o-sub (classoid-subclasses other))) (if (and s-sub o-sub) (collect ((res *empty-type* type-union)) (dohash ((subclass layout) s-sub :locked t) (declare (ignore layout)) (when (gethash subclass o-sub) (res (specifier-type subclass)))) (res)) *empty-type*))) (!define-type-method (classoid :simple-intersection2) (class1 class2) (declare (type classoid class1 class2)) (with-world-lock () (%ensure-both-classoids-valid class1 class2 "type intersection") (cond ((eq class1 class2) class1) ;; If one is a subclass of the other, then that is the ;; intersection. ((let ((subclasses (classoid-subclasses class2))) (and subclasses (gethash class1 subclasses))) class1) ((let ((subclasses (classoid-subclasses class1))) (and subclasses (gethash class2 subclasses))) 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 (structure-classoid-p class1) (structure-classoid-p class2)) ;; No subclass of both can be defined. *empty-type*) ((eq (classoid-state class1) :sealed) ;; checking whether a subclass of both can be defined: (sealed-class-intersection2 class1 class2)) ((eq (classoid-state class2) :sealed) ;; checking whether a subclass of both can be defined: (sealed-class-intersection2 class2 class1)) (t ;; 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 ;;; defining a subclass of both classes. The necessity for changing ;;; the default return value from SUBTYPEP to NIL, T if no alternate ;;; method is present comes about because, unlike the other places we ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the ;;; like, classes are in their own hierarchy with no possibility of ;;; mixtures with other type classes. (!define-type-method (classoid :complex-subtypep-arg2) (type1 class2) (if (and (intersection-type-p type1) (> (count-if #'classoid-p (intersection-type-types type1)) 1)) (values nil nil) (invoke-complex-subtypep-arg1-method type1 class2 nil t))) (!define-type-method (classoid :negate) (type) (make-negation-type :type type)) (!define-type-method (classoid :unparse) (type) (classoid-proper-name type)) ;;;; PCL stuff ;;; 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))) ;;; 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 ;;; The BUILT-IN-CLASSES list is a data structure which configures the ;;; creation of all the built-in classes. It contains all the info ;;; that we need to maintain the mapping between classes, compile-time ;;; types and run-time type codes. These options are defined: ;;; ;;; :TRANSLATION (default none) ;;; When this class is "parsed" as a type specifier, it is ;;; translated into the specified internal type representation, ;;; rather than being left as a class. This is used for types ;;; which we want to canonicalize to some other kind of type ;;; object because in general we want to be able to include more ;;; information than just the class (e.g. for numeric types.) ;;; ;;; :ENUMERABLE (default NIL) ;;; The value of the :ENUMERABLE slot in the created class. ;;; Meaningless in translated classes. ;;; ;;; :STATE (default :SEALED) ;;; The value of CLASS-STATE which we want on completion, ;;; indicating whether subclasses can be created at run-time. ;;; ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical) ;;; True if we can assign this class a unique inheritance depth. ;;; ;;; :CODES (default none) ;;; Run-time type codes which should be translated back to this ;;; class by CLASS-OF. Unspecified for abstract classes. ;;; ;;; :INHERITS (default this class and T) ;;; The class-precedence list for this class, with this class and ;;; T implicit. ;;; ;;; :DIRECT-SUPERCLASSES (default to head of CPL) ;;; List of the direct superclasses of this class. ;;; ;;; FIXME: This doesn't seem to be needed after cold init (and so can ;;; probably be uninterned at the end of cold init). (defvar *built-in-classes*) (!cold-init-forms (/show0 "setting *BUILT-IN-CLASSES*") (setq *built-in-classes* '((t :state :read-only :translation t) (character :enumerable t :codes (#.sb!vm:character-widetag) :translation (character-set) :prototype-form (code-char 42)) (symbol :codes (#.sb!vm:symbol-header-widetag) :prototype-form '#:mu) (system-area-pointer :codes (#.sb!vm:sap-widetag) :prototype-form (sb!sys:int-sap 42)) (weak-pointer :codes (#.sb!vm:weak-pointer-widetag) :prototype-form (sb!ext:make-weak-pointer (find-package "CL"))) (code-component :codes (#.sb!vm:code-header-widetag)) (lra :codes (#.sb!vm:return-pc-header-widetag)) (fdefn :codes (#.sb!vm:fdefn-widetag) :prototype-form (sb!kernel:make-fdefn "42")) (random-class) ; used for unknown type codes (function :codes (#.sb!vm:closure-header-widetag #.sb!vm:simple-fun-header-widetag) :state :read-only :prototype-form (function (lambda () 42))) (number :translation number) (complex :translation complex :inherits (number) :codes (#.sb!vm:complex-widetag) :prototype-form (complex 42 42)) (complex-single-float :translation (complex single-float) :inherits (complex number) :codes (#.sb!vm:complex-single-float-widetag) :prototype-form (complex 42f0 42f0)) (complex-double-float :translation (complex double-float) :inherits (complex number) :codes (#.sb!vm:complex-double-float-widetag) :prototype-form (complex 42d0 42d0)) #!+long-float (complex-long-float :translation (complex long-float) :inherits (complex number) :codes (#.sb!vm:complex-long-float-widetag) :prototype-form (complex 42l0 42l0)) (real :translation real :inherits (number)) (float :translation float :inherits (real number)) (single-float :translation single-float :inherits (float real number) :codes (#.sb!vm:single-float-widetag) :prototype-form 42f0) (double-float :translation double-float :inherits (float real number) :codes (#.sb!vm:double-float-widetag) :prototype-form 42d0) #!+long-float (long-float :translation long-float :inherits (float real number) :codes (#.sb!vm:long-float-widetag) :prototype-form 42l0) (rational :translation rational :inherits (real number)) (ratio :translation (and rational (not integer)) :inherits (rational real number) :codes (#.sb!vm:ratio-widetag) :prototype-form 1/42) (integer :translation integer :inherits (rational real number)) (fixnum :translation (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum) :inherits (integer rational real number) :codes #.(mapcar #'symbol-value sb!vm::fixnum-lowtags) :prototype-form 42) (bignum :translation (and integer (not fixnum)) :inherits (integer rational real number) :codes (#.sb!vm:bignum-widetag) :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2)))) (array :translation array :codes (#.sb!vm:complex-array-widetag) :hierarchical-p nil :prototype-form (make-array nil :adjustable t)) (simple-array :translation simple-array :codes (#.sb!vm:simple-array-widetag) :inherits (array) :prototype-form (make-array nil)) (sequence :translation (or cons (member nil) vector extended-sequence) :state :read-only :depth 2) (vector :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-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0)) (bit-vector :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) :inherits (vector array sequence) :prototype-form (make-array 0 :element-type 'bit :fill-pointer t)) (simple-bit-vector :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) :prototype-form (make-array 0 :element-type 'bit)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 2))) (simple-array-unsigned-byte-4 :translation (simple-array (unsigned-byte 4) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 4))) (simple-array-unsigned-byte-7 :translation (simple-array (unsigned-byte 7) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-7-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 7))) (simple-array-unsigned-byte-8 :translation (simple-array (unsigned-byte 8) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 8))) (simple-array-unsigned-byte-15 :translation (simple-array (unsigned-byte 15) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-15-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 15))) (simple-array-unsigned-byte-16 :translation (simple-array (unsigned-byte 16) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 16))) (simple-array-unsigned-fixnum :translation (simple-array (unsigned-byte #.sb!vm:n-positive-fixnum-bits) (*)) :codes (#.sb!vm:simple-array-unsigned-fixnum-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte #.sb!vm:n-positive-fixnum-bits))) (simple-array-unsigned-byte-31 :translation (simple-array (unsigned-byte 31) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-31-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 31))) (simple-array-unsigned-byte-32 :translation (simple-array (unsigned-byte 32) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 32))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (simple-array-unsigned-byte-63 :translation (simple-array (unsigned-byte 63) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 63))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (simple-array-unsigned-byte-64 :translation (simple-array (unsigned-byte 64) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-64-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 64))) (simple-array-signed-byte-8 :translation (simple-array (signed-byte 8) (*)) :codes (#.sb!vm:simple-array-signed-byte-8-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 8))) (simple-array-signed-byte-16 :translation (simple-array (signed-byte 16) (*)) :codes (#.sb!vm:simple-array-signed-byte-16-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 16))) (simple-array-fixnum :translation (simple-array (signed-byte #.sb!vm:n-fixnum-bits) (*)) :codes (#.sb!vm:simple-array-fixnum-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte #.sb!vm:n-fixnum-bits))) (simple-array-signed-byte-32 :translation (simple-array (signed-byte 32) (*)) :codes (#.sb!vm:simple-array-signed-byte-32-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 32))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (simple-array-signed-byte-64 :translation (simple-array (signed-byte 64) (*)) :codes (#.sb!vm:simple-array-signed-byte-64-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 64))) (simple-array-single-float :translation (simple-array single-float (*)) :codes (#.sb!vm:simple-array-single-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'single-float)) (simple-array-double-float :translation (simple-array double-float (*)) :codes (#.sb!vm:simple-array-double-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'double-float)) #!+long-float (simple-array-long-float :translation (simple-array long-float (*)) :codes (#.sb!vm:simple-array-long-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'long-float)) (simple-array-complex-single-float :translation (simple-array (complex single-float) (*)) :codes (#.sb!vm:simple-array-complex-single-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(complex single-float))) (simple-array-complex-double-float :translation (simple-array (complex double-float) (*)) :codes (#.sb!vm:simple-array-complex-double-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(complex double-float))) #!+long-float (simple-array-complex-long-float :translation (simple-array (complex long-float) (*)) :codes (#.sb!vm:simple-array-complex-long-float-widetag) :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(complex long-float))) (string :translation string :direct-superclasses (vector) :inherits (vector array sequence)) (simple-string :translation simple-string :direct-superclasses (string simple-array) :inherits (string vector simple-array array sequence)) (vector-nil :translation (vector nil) :codes (#.sb!vm:complex-vector-nil-widetag) :direct-superclasses (string) :inherits (string vector array sequence) :prototype-form (make-array 0 :element-type 'nil :fill-pointer t)) (simple-array-nil :translation (simple-array nil (*)) :codes (#.sb!vm:simple-array-nil-widetag) :direct-superclasses (vector-nil simple-string) :inherits (vector-nil simple-string string vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'nil)) (base-string :translation base-string :codes (#.sb!vm:complex-base-string-widetag) :direct-superclasses (string) :inherits (string vector array sequence) :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t)) (simple-base-string :translation simple-base-string :codes (#.sb!vm:simple-base-string-widetag) :direct-superclasses (base-string simple-string) :inherits (base-string simple-string string vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'base-char)) #!+sb-unicode (character-string :translation (vector character) :codes (#.sb!vm:complex-character-string-widetag) :direct-superclasses (string) :inherits (string vector array sequence) :prototype-form (make-array 0 :element-type 'character :fill-pointer t)) #!+sb-unicode (simple-character-string :translation (simple-array character (*)) :codes (#.sb!vm:simple-character-string-widetag) :direct-superclasses (character-string simple-string) :inherits (character-string simple-string string vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'character)) (list :translation (or cons (member nil)) :inherits (sequence)) (cons :codes (#.sb!vm:list-pointer-lowtag) :translation cons :inherits (list sequence) :prototype-form (cons nil nil)) (null :translation (member nil) :inherits (symbol list sequence) :direct-superclasses (symbol list) :prototype-form 'nil) (stream :state :read-only :depth 2) (file-stream :state :read-only :depth 4 :inherits (stream)) (string-stream :state :read-only :depth 4 :inherits (stream))))) ;;; See also src/code/class-init.lisp where we finish setting up the ;;; translations for built-in types. (!cold-init-forms (dolist (x *built-in-classes*) #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*") (destructuring-bind (name &key (translation nil trans-p) inherits codes enumerable state depth prototype-form (hierarchical-p t) ; might be modified below (direct-superclasses (if inherits (list (car inherits)) '(t)))) x (declare (ignore codes state translation prototype-form)) (let ((inherits-list (if (eq name t) () (cons t (reverse inherits)))) (classoid (make-built-in-classoid :enumerable enumerable :name name :translation (if trans-p :initializing nil) :direct-superclasses (if (eq name t) nil (mapcar #'find-classoid direct-superclasses))))) (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive (classoid-cell-classoid (find-classoid-cell name :create t)) classoid) (unless trans-p (setf (info :type :builtin name) classoid)) (let* ((inherits-vector (map 'simple-vector (lambda (x) (let ((super-layout (classoid-layout (find-classoid x)))) (when (minusp (layout-depthoid super-layout)) (setf hierarchical-p nil)) super-layout)) inherits-list)) (depthoid (if hierarchical-p (or depth (length inherits-vector)) -1))) (register-layout (find-and-init-or-check-layout name 0 inherits-vector depthoid 0) :invalidate nil))))) (/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 ;;; is loaded and the class defined. (!cold-init-forms (/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 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 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 ;; 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 stream stream)))) (/show0 "defining temporary STANDARD-CLASS") (let* ((name (first x)) (inherits-list (second x)) (classoid (make-standard-classoid :name name)) (classoid-cell (find-classoid-cell name :create t))) ;; Needed to open-code the MAP, below (declare (type list inherits-list)) (setf (classoid-cell-classoid classoid-cell) classoid (info :type :kind name) :instance) (let ((inherits (map 'simple-vector (lambda (x) (classoid-layout (find-classoid 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 0) :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. (!cold-init-forms (dolist (x *built-in-classes*) (destructuring-bind (name &key (state :sealed) &allow-other-keys) x (setf (classoid-state (find-classoid name)) state)))) ;;;; class definition/redefinition ;;; This is to be called whenever we are altering a class. (defun %modify-classoid (classoid) (clear-type-caches) (when (member (classoid-state classoid) '(:read-only :frozen)) ;; FIXME: This should probably be CERROR. (warn "making ~(~A~) class ~S writable" (classoid-state classoid) (classoid-name classoid)) (setf (classoid-state classoid) nil))) ;;; 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.) 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) (setf (layout-clos-hash layout) 0) (let ((inherits (layout-inherits layout)) (classoid (layout-classoid layout))) (%modify-classoid classoid) (dovector (super inherits) (let ((subs (classoid-subclasses (layout-classoid super)))) (when subs (remhash classoid subs))))) (values)) ;;;; cold loading initializations ;;; 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 build-order.lisp-expr sequence, and be put in ;;; !COLD-INIT-FORMS there? (defun !class-finalize () (dohash ((name layout) *forward-referenced-layouts*) (let ((class (find-classoid name nil))) (cond ((not class) (setf (layout-classoid layout) (make-undefined-classoid name))) ((eq (classoid-layout class) layout) (remhash name *forward-referenced-layouts*)) (t (error "Something strange with forward layout for ~S:~% ~S" name layout)))))) (!cold-init-forms #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*") (setq *built-in-class-codes* (let* ((initial-element (locally ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for ;; constant class names which creates fast but ;; non-cold-loadable, non-compact code. In this ;; context, we'd rather have compact, cold-loadable ;; code. -- WHN 19990928 (declare (notinline find-classoid)) (classoid-layout (find-classoid 'random-class)))) (res (make-array 256 :initial-element initial-element))) (dolist (x *built-in-classes* res) (destructuring-bind (name &key codes &allow-other-keys) x (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)