src/code/class.lisp

   1 ;;;; This file contains structures and functions for the maintenance of
   2 ;;;; basic information about defined types. Different object systems
   3 ;;;; can be supported simultaneously. Some of the functions here are
   4 ;;;; nominally generic, and are overwritten when CLOS is loaded.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!KERNEL")
  16
  17 (file-comment
  18   "$Header$")
  19
  20 (!begin-collecting-cold-init-forms)
  21 \f
  22 ;;;; the CLASS structure
  23
  24 ;;; The CLASS structure is a supertype of all class types. A CLASS is
  25 ;;; also a CTYPE structure as recognized by the type system.
  26 (def!struct (;; FIXME: Yes, these #+SB-XC/#-SB-XC conditionals are
  27              ;; pretty hairy. I'm considering cleaner ways to rewrite
  28              ;; the whole build system to avoid these (and other hacks
  29              ;; too, e.g. UNCROSS) but I'm not sure yet that I've got
  30              ;; it figured out. -- WHN 19990729
  31              #-sb-xc sb!xc:class
  32              #+sb-xc cl:class
  33              (:make-load-form-fun class-make-load-form-fun)
  34              (:include ctype
  35                        (:class-info (type-class-or-lose #-sb-xc 'sb!xc:class
  36                                                         #+sb-xc 'cl:class)))
  37              (:constructor nil)
  38              #-no-ansi-print-object
  39              (:print-object
  40               (lambda (class stream)
  41                 (let ((name (sb!xc:class-name class)))
  42                   (print-unreadable-object (class stream
  43                                                   :type t
  44                                                   :identity (not name))
  45                     (format stream
  46                             ;; FIXME: Make sure that this prints
  47                             ;; reasonably for anonymous classes.
  48                             "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
  49                             name
  50                             (class-state class))))))
  51              #-sb-xc-host (:pure nil))
  52   ;; the value to be returned by CLASS-NAME. (CMU CL used the raw slot
  53   ;; accessor for this slot directly as the definition of
  54   ;; CL:CLASS-NAME, but that was slightly wrong, because ANSI says
  55   ;; that CL:CLASS-NAME is a generic function.)
  56   (%name nil :type symbol)
  57   ;; the current layout for this class, or NIL if none assigned yet
  58   (layout nil :type (or sb!kernel::layout null))
  59   ;; How sure are we that this class won't be redefined?
  60   ;;   :READ-ONLY = We are committed to not changing the effective
  61   ;;                slots or superclasses.
  62   ;;   :SEALED    = We can't even add subclasses.
  63   ;;   NIL        = Anything could happen.
  64   (state nil :type (member nil :read-only :sealed))
  65   ;; direct superclasses of this class
  66   (direct-superclasses () :type list)
  67   ;; representation of all of the subclasses (direct or indirect) of
  68   ;; this class. This is NIL if no subclasses or not initalized yet;
  69   ;; otherwise, it's an EQ hash-table mapping CL:CLASS objects to the
  70   ;; subclass layout that was in effect at the time the subclass was
  71   ;; created.
  72   (subclasses nil :type (or null hash-table))
  73   ;; the PCL class object for this class, or NIL if none assigned yet
  74   (pcl-class nil))
  75
  76 ;;; KLUDGE: ANSI says this is a generic function, but we need it for
  77 ;;; bootstrapping before CLOS exists, so we define it as an ordinary
  78 ;;; function and let CLOS code overwrite it later. -- WHN ca. 19990815
  79 (defun sb!xc:class-name (class)
  80   (class-%name class))
  81
  82 (defun class-make-load-form-fun (class)
  83   (/show "entering CLASS-MAKE-LOAD-FORM-FUN" class)
  84   (let ((name (sb!xc:class-name class)))
  85     (unless (and name (eq (sb!xc:find-class name nil) class))
  86       (/show "anonymous/undefined class case")
  87       (error "can't use anonymous or undefined class as constant:~%  ~S"
  88              class))
  89     `(locally
  90        ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
  91        ;; names which creates fast but non-cold-loadable, non-compact
  92        ;; code. In this context, we'd rather have compact,
  93        ;; cold-loadable code. -- WHN 19990928
  94        (declare (notinline sb!xc:find-class))
  95        (sb!xc:find-class ',name))))
  96 \f
  97 ;;;; basic LAYOUT stuff
  98
  99 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
 100 ;;; in order to guarantee that several hash values can be added without
 101 ;;; overflowing into a bignum.
 102 (defconstant layout-clos-hash-max (ash most-positive-fixnum -3)
 103   #!+sb-doc
 104   "the inclusive upper bound on LAYOUT-CLOS-HASH values")
 105
 106 ;;; a list of conses, initialized by genesis
 107 ;;;
 108 ;;; In each cons, the car is the symbol naming the layout, and the
 109 ;;; cdr is the layout itself.
 110 (defvar *!initial-layouts*)
 111
 112 ;;; a table mapping class names to layouts for classes we have
 113 ;;; referenced but not yet loaded. This is initialized from an alist
 114 ;;; created by genesis describing the layouts that genesis created at
 115 ;;; cold-load time.
 116 (defvar *forward-referenced-layouts*)
 117 (!cold-init-forms
 118   (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
 119   #-sb-xc-host (progn
 120                  (/show0 "processing *!INITIAL-LAYOUTS*")
 121                  (dolist (x *!initial-layouts*)
 122                    (setf (gethash (car x) *forward-referenced-layouts*)
 123                          (cdr x)))
 124                  (/show0 "done processing *!INITIAL-LAYOUTS*")))
 125
 126 ;;; The LAYOUT structure is pointed to by the first cell of instance
 127 ;;; (or structure) objects. It represents what we need to know for
 128 ;;; type checking and garbage collection. Whenever a class is
 129 ;;; incompatibly redefined, a new layout is allocated. If two object's
 130 ;;; layouts are EQ, then they are exactly the same type.
 131 ;;;
 132 ;;; KLUDGE: The genesis code has raw offsets of slots in this
 133 ;;; structure hardwired into it. It would be good to rewrite that code
 134 ;;; so that it looks up those offsets in the compiler's tables, but
 135 ;;; for now if you change this structure, lucky you, you get to grovel
 136 ;;; over the genesis code by hand.:-( -- WHN 19990820
 137 (def!struct (layout
 138              ;; KLUDGE: A special hack keeps this from being
 139              ;; called when building code for the
 140              ;; cross-compiler. See comments at the DEFUN for
 141              ;; this. -- WHN 19990914
 142              (:make-load-form-fun #-sb-xc-host ignore-it
 143                                   ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
 144                                   ;; time controls both the
 145                                   ;; build-the-cross-compiler behavior
 146                                   ;; and the run-the-cross-compiler
 147                                   ;; behavior. The value below only
 148                                   ;; works for build-the-cross-compiler.
 149                                   ;; There's a special hack in
 150                                   ;; EMIT-MAKE-LOAD-FORM which gives
 151                                   ;; effectively IGNORE-IT behavior for
 152                                   ;; LAYOUT at run-the-cross-compiler
 153                                   ;; time. It would be cleaner to
 154                                   ;; actually have an IGNORE-IT value
 155                                   ;; stored, but it's hard to see how to
 156                                   ;; do that concisely with the current
 157                                   ;; DEF!STRUCT setup. -- WHN 19990930
 158                                   #+sb-xc-host
 159                                   make-load-form-for-layout))
 160   ;; hash bits which should be set to constant pseudo-random values
 161   ;; for use by CLOS. Sleazily accessed via %INSTANCE-REF, see
 162   ;; LAYOUT-CLOS-HASH.
 163   ;;
 164   ;; FIXME: We should get our story straight on what the type of these
 165   ;; values is. (declared INDEX here, described as <=
 166   ;; LAYOUT-CLOS-HASH-MAX by the doc string of that constant,
 167   ;; generated as strictly positive in RANDOM-LAYOUT-CLOS-HASH..)
 168   ;;
 169   ;; KLUDGE: The fact that the slots here start at offset 1 is known
 170   ;; to the LAYOUT-CLOS-HASH function and to the LAYOUT-dumping code
 171   ;; in GENESIS.
 172   (clos-hash-0 (random-layout-clos-hash) :type index)
 173   (clos-hash-1 (random-layout-clos-hash) :type index)
 174   (clos-hash-2 (random-layout-clos-hash) :type index)
 175   (clos-hash-3 (random-layout-clos-hash) :type index)
 176   (clos-hash-4 (random-layout-clos-hash) :type index)
 177   (clos-hash-5 (random-layout-clos-hash) :type index)
 178   (clos-hash-6 (random-layout-clos-hash) :type index)
 179   (clos-hash-7 (random-layout-clos-hash) :type index)
 180   ;; the class that this is a layout for
 181   (class (required-argument)
 182          ;; FIXME: Do we really know this is a CL:CLASS? Mightn't it
 183          ;; be a SB-PCL:CLASS under some circumstances? What goes here
 184          ;; when the LAYOUT is in fact a PCL::WRAPPER?
 185          :type #-sb-xc sb!xc:class #+sb-xc cl:class)
 186   ;; The value of this slot can be
 187   ;;   * :UNINITIALIZED if not initialized yet;
 188   ;;   * NIL if this is the up-to-date layout for a class; or
 189   ;;   * T if this layout has been invalidated (by being replaced by
 190   ;;     a new, more-up-to-date LAYOUT).
 191   ;;   * something else (probably a list) if the class is a PCL wrapper
 192   ;;     and PCL has made it invalid and made a note to itself about it
 193   (invalid :uninitialized :type (or cons (member nil t :uninitialized)))
 194   ;; The layouts for all classes we inherit. If hierarchical these are
 195   ;; in order from most general down to (but not including) this
 196   ;; class.
 197   ;;
 198   ;; FIXME: Couldn't this be (SIMPLE-ARRAY LAYOUT 1) instead of
 199   ;; SIMPLE-VECTOR?
 200   (inherits #() :type simple-vector)
 201   ;; If inheritance is hierarchical, this is -1. If inheritance is not
 202   ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
 203   ;; Note:
 204   ;;  (1) This turns out to be a handy encoding for arithmetically
 205   ;;      comparing deepness; it is generally useful to do a bare numeric
 206   ;;      comparison of these depthoid values, and we hardly ever need to
 207   ;;      test whether the values are negative or not.
 208   ;;  (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
 209   ;;      renamed because some of us find it confusing to call something
 210   ;;      a depth when it isn't quite.
 211   (depthoid -1 :type layout-depthoid)
 212   ;; The number of top-level descriptor cells in each instance.
 213   (length 0 :type index)
 214   ;; If this layout has some kind of compiler meta-info, then this is
 215   ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
 216   (info nil)
 217   ;; This is true if objects of this class are never modified to
 218   ;; contain dynamic pointers in their slots or constant-like
 219   ;; substructure (and hence can be copied into read-only space by
 220   ;; PURIFY).
 221   ;;
 222   ;; KLUDGE: This slot is known to the C runtime support code.
 223   (pure nil :type (member t nil 0)))
 224
 225 (def!method print-object ((layout layout) stream)
 226   (print-unreadable-object (layout stream :type t :identity t)
 227     (format stream
 228             "for ~S~@[, INVALID=~S~]"
 229             (layout-proper-name layout)
 230             (layout-invalid layout))))
 231
 232 (eval-when (:compile-toplevel :load-toplevel :execute)
 233   (defun layout-proper-name (layout)
 234     (class-proper-name (layout-class layout))))
 235 \f
 236 ;;;; support for the hash values used by CLOS when working with LAYOUTs
 237
 238 (defconstant layout-clos-hash-length 8)
 239 #!-sb-fluid (declaim (inline layout-clos-hash))
 240 (defun layout-clos-hash (layout i)
 241   ;; FIXME: Either this I should be declared to be `(MOD
 242   ;; ,LAYOUT-CLOS-HASH-LENGTH), or this is used in some inner loop
 243   ;; where we can't afford to check that kind of thing and therefore
 244   ;; should have some insane level of optimization. (This is true both
 245   ;; of this function and of the SETF function below.)
 246   (declare (type layout layout) (type index i))
 247   ;; FIXME: LAYOUT slots should have type `(MOD ,LAYOUT-CLOS-HASH-MAX),
 248   ;; not INDEX.
 249   (truly-the index (%instance-ref layout (1+ i))))
 250 #!-sb-fluid (declaim (inline (setf layout-clos-hash)))
 251 (defun (setf layout-clos-hash) (new-value layout i)
 252   (declare (type layout layout) (type index new-value i))
 253   (setf (%instance-ref layout (1+ i)) new-value))
 254
 255 ;;; a generator for random values suitable for the CLOS-HASH slots of
 256 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
 257 ;;; pseudo-random values to come the same way in the target even when
 258 ;;; we make minor changes to the system, in order to reduce the
 259 ;;; mysteriousness of possible CLOS bugs.
 260 (defvar *layout-clos-hash-random-state*)
 261 (defun random-layout-clos-hash ()
 262   ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
 263   ;; returning a strictly positive value. I copied it verbatim from
 264   ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
 265   ;; dunno whether the hash values are really supposed to be 1-based.
 266   ;; They're declared as INDEX.. Or is this a hack to try to avoid
 267   ;; having to use bignum arithmetic? Or what? An explanation would be
 268   ;; nice.
 269   (1+ (random layout-clos-hash-max
 270               (if (boundp '*layout-clos-hash-random-state*)
 271                   *layout-clos-hash-random-state*
 272                   (setf *layout-clos-hash-random-state*
 273                         (make-random-state))))))
 274 \f
 275 ;;; If we can't find any existing layout, then we create a new one
 276 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
 277 ;;; used to immediately check for compatibility, but for
 278 ;;; cross-compilability reasons (i.e. convenience of using this
 279 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
 280 ;;; been split off into INIT-OR-CHECK-LAYOUT.
 281 (declaim (ftype (function (symbol) layout) find-layout))
 282 (defun find-layout (name)
 283   (let ((class (sb!xc:find-class name nil)))
 284     (or (and class (class-layout class))
 285         (gethash name *forward-referenced-layouts*)
 286         (setf (gethash name *forward-referenced-layouts*)
 287               (make-layout :class (or class (make-undefined-class name)))))))
 288
 289 ;;; If LAYOUT is uninitialized, initialize it with CLASS, LENGTH,
 290 ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
 291 ;;; with CLASS, LENGTH, INHERITS, and DEPTHOID.
 292 ;;;
 293 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
 294 ;;; anything about the class", so if LAYOUT is initialized, any
 295 ;;; preexisting class slot value is OK, and if it's not initialized,
 296 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
 297 ;;; is no longer true, :UNINITIALIZED used instead.
 298 (declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid) layout)
 299                 init-or-check-layout))
 300 (defun init-or-check-layout (layout class length inherits depthoid)
 301   (cond ((eq (layout-invalid layout) :uninitialized)
 302          ;; There was no layout before, we just created one which
 303          ;; we'll now initialize with our information.
 304          (setf (layout-length layout) length
 305                (layout-inherits layout) inherits
 306                (layout-depthoid layout) depthoid
 307                (layout-class layout) class
 308                (layout-invalid layout) nil))
 309         ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
 310         ;; clause is not needed?
 311         ((not *type-system-initialized*)
 312          (setf (layout-class layout) class))
 313         (t
 314          ;; There was an old layout already initialized with old
 315          ;; information, and we'll now check that old information
 316          ;; which was known with certainty is consistent with current
 317          ;; information which is known with certainty.
 318          (check-layout layout class length inherits depthoid)))
 319   layout)
 320
 321 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the
 322 ;;; standard load form mechanism, we use special fops instead, in
 323 ;;; order to make cold load come out right. But when we're building
 324 ;;; the cross-compiler, we can't do that because we don't have access
 325 ;;; to special non-ANSI low-level things like special fops, and we
 326 ;;; don't need to do that anyway because our code isn't going to be
 327 ;;; cold loaded, so we use the ordinary load form system.
 328 ;;;
 329 ;;; KLUDGE: A special hack causes this not to be called when we are
 330 ;;; building code for the target Lisp. It would be tidier to just not
 331 ;;; have it in place when we're building the target Lisp, but it
 332 ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
 333 ;;; bit, so I punted. -- WHN 19990914
 334 #+sb-xc-host
 335 (defun make-load-form-for-layout (layout &optional env)
 336   (declare (type layout layout))
 337   (declare (ignore env))
 338   (when (layout-invalid layout)
 339     (compiler-error "can't dump reference to obsolete class: ~S"
 340                     (layout-class layout)))
 341   (let ((name (sb!xc:class-name (layout-class layout))))
 342     (unless name
 343       (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
 344     ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
 345     ;; we have to do this in two stages, a la the TREE-WITH-PARENT
 346     ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
 347     (values
 348      ;; "creation" form (which actually doesn't create a new LAYOUT if
 349      ;; there's a preexisting one with this name)
 350      `(find-layout ',name)
 351      ;; "initialization" form (which actually doesn't initialize
 352      ;; preexisting LAYOUTs, just checks that they're consistent).
 353      `(init-or-check-layout ',layout
 354                             ',(layout-class layout)
 355                             ',(layout-length layout)
 356                             ',(layout-inherits layout)
 357                             ',(layout-depthoid layout)))))
 358
 359 ;;; If LAYOUT's slot values differ from the specified slot values in
 360 ;;; any interesting way, then give a warning and return T.
 361 (declaim (ftype (function (simple-string
 362                            layout
 363                            simple-string
 364                            index
 365                            simple-vector
 366                            layout-depthoid))
 367                 redefine-layout-warning))
 368 (defun redefine-layout-warning (old-context old-layout
 369                                 context length inherits depthoid)
 370   (declare (type layout old-layout) (type simple-string old-context context))
 371   (let ((name (layout-proper-name old-layout)))
 372     (or (let ((old-inherits (layout-inherits old-layout)))
 373           (or (when (mismatch old-inherits
 374                               inherits
 375                               :key #'layout-proper-name)
 376                 (warn "change in superclasses of class ~S:~%  ~
 377                        ~A superclasses: ~S~%  ~
 378                        ~A superclasses: ~S"
 379                       name
 380                       old-context
 381                       (map 'list #'layout-proper-name old-inherits)
 382                       context
 383                       (map 'list #'layout-proper-name inherits))
 384                 t)
 385               (let ((diff (mismatch old-inherits inherits)))
 386                 (when diff
 387                   (warn
 388                    "in class ~S:~%  ~
 389                     ~:(~A~) definition of superclass ~S is incompatible with~%  ~
 390                     ~A definition."
 391                    name
 392                    old-context
 393                    (layout-proper-name (svref old-inherits diff))
 394                    context)
 395                   t))))
 396         (let ((old-length (layout-length old-layout)))
 397           (unless (= old-length length)
 398             (warn "change in instance length of class ~S:~%  ~
 399                    ~A length: ~D~%  ~
 400                    ~A length: ~D"
 401                   name
 402                   old-context old-length
 403                   context length)
 404             t))
 405         (unless (= (layout-depthoid old-layout) depthoid)
 406           (warn "change in the inheritance structure of class ~S~%  ~
 407                  between the ~A definition and the ~A definition"
 408                 name old-context context)
 409           t))))
 410
 411 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
 412 ;;; INHERITS, and DEPTHOID.
 413 (declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
 414                 check-layout))
 415 (defun check-layout (layout class length inherits depthoid)
 416   (assert (eq (layout-class layout) class))
 417   (when (redefine-layout-warning "current" layout
 418                                  "compile time" length inherits depthoid)
 419     ;; Classic CMU CL had more options here. There are several reasons
 420     ;; why they might want more options which are less appropriate for
 421     ;; us: (1) It's hard to fit the classic CMU CL flexible approach
 422     ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
 423     ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
 424     ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
 425     ;; We have CLOS now, and if you want to be able to flexibly
 426     ;; redefine classes without restarting the system, it'd make sense
 427     ;; to use that, so supporting complexity in order to allow
 428     ;; modifying DEFSTRUCTs without restarting the system is a low
 429     ;; priority. (3) We now have the ability to rebuild the SBCL
 430     ;; system from scratch, so we no longer need this functionality in
 431     ;; order to maintain the SBCL system by modifying running images.
 432     (error "The class ~S was not changed, and there's no guarantee that~@
 433             the loaded code (which expected another layout) will work."
 434            (layout-proper-name layout)))
 435   (values))
 436
 437 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
 438 ;;; single function call
 439 ;;;
 440 ;;; Used by the loader to forward-reference layouts for classes whose
 441 ;;; definitions may not have been loaded yet. This allows type tests
 442 ;;; to be loaded when the type definition hasn't been loaded yet.
 443 (declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
 444                 find-and-init-or-check-layout))
 445 (defun find-and-init-or-check-layout (name length inherits depthoid)
 446   (let ((layout (find-layout name)))
 447     (init-or-check-layout layout
 448                           (or (sb!xc:find-class name nil)
 449                               (make-undefined-class name))
 450                           length
 451                           inherits
 452                           depthoid)))
 453
 454 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
 455 ;;; of all superclasses. This is the operation that "installs" a
 456 ;;; layout for a class in the type system, clobbering any old layout.
 457 ;;; However, this does not modify the class namespace; that is a
 458 ;;; separate operation (think anonymous classes.)
 459 ;;; -- If INVALIDATE, then all the layouts for any old definition
 460 ;;;    and subclasses are invalidated, and the SUBCLASSES slot is cleared.
 461 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
 462 ;;;    destructively modified to hold the same type information.
 463 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 464 (defun register-layout (layout &key (invalidate t) destruct-layout)
 465   (declare (type layout layout) (type (or layout null) destruct-layout))
 466   (let* ((class (layout-class layout))
 467          (class-layout (class-layout class))
 468          (subclasses (class-subclasses class)))
 469
 470     ;; Attempting to register ourselves with a temporary cookie is
 471     ;; almost certainly a programmer error. (I should know, I did it.)
 472     ;; -- WHN 19990927
 473     (assert (not (undefined-class-p class)))
 474
 475     ;; This assertion dates from classic CMU CL. The rationale is
 476     ;; probably that calling REGISTER-LAYOUT more than once for the
 477     ;; same LAYOUT is almost certainly a programmer error.
 478     (assert (not (eq class-layout layout)))
 479
 480     ;; Figure out what classes are affected by the change, and issue
 481     ;; appropriate warnings and invalidations.
 482     (when class-layout
 483       (modify-class class)
 484       (when subclasses
 485         (dohash (subclass subclass-layout subclasses)
 486           (modify-class subclass)
 487           (when invalidate
 488             (invalidate-layout subclass-layout))))
 489       (when invalidate
 490         (invalidate-layout class-layout)
 491         (setf (class-subclasses class) nil)))
 492
 493     (if destruct-layout
 494         (setf (layout-invalid destruct-layout) nil
 495               (layout-inherits destruct-layout) (layout-inherits layout)
 496               (layout-depthoid destruct-layout)(layout-depthoid layout)
 497               (layout-length destruct-layout) (layout-length layout)
 498               (layout-info destruct-layout) (layout-info layout)
 499               (class-layout class) destruct-layout)
 500         (setf (layout-invalid layout) nil
 501               (class-layout class) layout))
 502
 503     (let ((inherits (layout-inherits layout)))
 504       (dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
 505         (let* ((super (layout-class (svref inherits i)))
 506                (subclasses (or (class-subclasses super)
 507                                (setf (class-subclasses super)
 508                                      (make-hash-table :test 'eq)))))
 509           (when (and (eq (class-state super) :sealed)
 510                      (not (gethash class subclasses)))
 511             (warn "unsealing sealed class ~S in order to subclass it"
 512                   (sb!xc:class-name super))
 513             (setf (class-state super) :read-only))
 514           (setf (gethash class subclasses)
 515                 (or destruct-layout layout))))))
 516
 517   (values))
 518 ); EVAL-WHEN
 519 \f
 520 ;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward
 521 ;;; referenced layouts. Users should never see them.
 522 (def!struct (undefined-class (:include #-sb-xc sb!xc:class
 523                                        #+sb-xc cl:class)
 524                              (:constructor make-undefined-class (%name))))
 525
 526 ;;; BUILT-IN-CLASS is used to represent the standard classes that
 527 ;;; aren't defined with DEFSTRUCT and other specially implemented
 528 ;;; primitive types whose only attribute is their name.
 529 ;;;
 530 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
 531 ;;; are effectively DEFTYPE'd to some other type (usually a union of
 532 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
 533 ;;; This translation is done when type specifiers are parsed. Type
 534 ;;; system operations (union, subtypep, etc.) should never encounter
 535 ;;; translated classes, only their translation.
 536 (def!struct (sb!xc:built-in-class (:include #-sb-xc sb!xc:class
 537                                             #+sb-xc cl:class)
 538                                   (:constructor bare-make-built-in-class))
 539   ;; the type we translate to on parsing. If NIL, then this class
 540   ;; stands on its own; or it can be set to :INITIALIZING for a period
 541   ;; during cold-load.
 542   (translation nil :type (or ctype (member nil :initializing))))
 543 (defun make-built-in-class (&rest rest)
 544   (apply #'bare-make-built-in-class
 545          (rename-keyword-args '((:name :%name)) rest)))
 546
 547 ;;; FIXME: In CMU CL, this was a class with a print function, but not
 548 ;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
 549 ;;; we let CLOS handle our print functions, so that is no longer needed.
 550 ;;; Is there any need for this class any more?
 551 (def!struct (slot-class (:include #-sb-xc sb!xc:class #+sb-xc cl:class)
 552                         (:constructor nil)))
 553
 554 ;;; STRUCTURE-CLASS represents what we need to know about structure
 555 ;;; classes. Non-structure "typed" defstructs are a special case, and
 556 ;;; don't have a corresponding class.
 557 (def!struct (basic-structure-class (:include slot-class)
 558                                    (:constructor nil)))
 559
 560 (def!struct (sb!xc:structure-class (:include basic-structure-class)
 561                                    (:constructor bare-make-structure-class))
 562   ;; If true, a default keyword constructor for this structure.
 563   (constructor nil :type (or function null)))
 564 (defun make-structure-class (&rest rest)
 565   (apply #'bare-make-structure-class
 566          (rename-keyword-args '((:name :%name)) rest)))
 567
 568 ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
 569 ;;; structures, which are used to implement generic functions.
 570 (def!struct (funcallable-structure-class (:include basic-structure-class)
 571                                          (:constructor bare-make-funcallable-structure-class)))
 572 (defun make-funcallable-structure-class (&rest rest)
 573   (apply #'bare-make-funcallable-structure-class
 574          (rename-keyword-args '((:name :%name)) rest)))
 575 \f
 576 ;;;; class namespace
 577
 578 ;;; We use an indirection to allow forward referencing of class
 579 ;;; definitions with load-time resolution.
 580 (def!struct (class-cell
 581              (:constructor make-class-cell (name &optional class))
 582              (:make-load-form-fun (lambda (c)
 583                                     `(find-class-cell ',(class-cell-name c))))
 584              #-no-ansi-print-object
 585              (:print-object (lambda (s stream)
 586                               (print-unreadable-object (s stream :type t)
 587                                 (prin1 (class-cell-name s) stream)))))
 588   ;; Name of class we expect to find.
 589   (name nil :type symbol :read-only t)
 590   ;; Class or NIL if not yet defined.
 591   (class nil :type (or #-sb-xc sb!xc:class #+sb-xc cl:class
 592                        null)))
 593 (defun find-class-cell (name)
 594   (or (info :type :class name)
 595       (setf (info :type :class name)
 596             (make-class-cell name))))
 597
 598 ;;; FIXME: When the system is stable, this DECLAIM FTYPE should
 599 ;;; probably go away in favor of the DEFKNOWN for FIND-CLASS.
 600 (declaim (ftype (function (symbol &optional t (or null sb!c::lexenv))) sb!xc:find-class))
 601 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 602 (defun sb!xc:find-class (name &optional (errorp t) environment)
 603   #!+sb-doc
 604   "Return the class with the specified NAME. If ERRORP is false, then NIL is
 605    returned when no such class exists."
 606   (declare (type symbol name) (ignore environment))
 607   (let ((res (class-cell-class (find-class-cell name))))
 608     (if (or res (not errorp))
 609         res
 610         (error "class not yet defined:~%  ~S" name))))
 611 (defun (setf sb!xc:find-class) (new-value name)
 612   #-sb-xc (declare (type sb!xc:class new-value))
 613   (ecase (info :type :kind name)
 614     ((nil))
 615     (:instance
 616      (let ((old (class-of (sb!xc:find-class name)))
 617            (new (class-of new-value)))
 618        (unless (eq old new)
 619          (warn "changing meta-class of ~S from ~S to ~S"
 620                name
 621                (class-name old)
 622                (class-name new)))))
 623     (:primitive
 624      (error "illegal to redefine standard type ~S" name))
 625     (:defined
 626      (warn "redefining DEFTYPE type to be a class: ~S" name)
 627      (setf (info :type :expander name) nil)))
 628
 629   (remhash name *forward-referenced-layouts*)
 630   (%note-type-defined name)
 631   (setf (info :type :kind name) :instance)
 632   (setf (class-cell-class (find-class-cell name)) new-value)
 633   (unless (eq (info :type :compiler-layout name)
 634               (class-layout new-value))
 635     (setf (info :type :compiler-layout name) (class-layout new-value)))
 636   new-value)
 637 ) ; EVAL-WHEN
 638
 639 ;;; Called when we are about to define NAME as a class meeting some
 640 ;;; predicate (such as a meta-class type test.) The first result is
 641 ;;; always of the desired class. The second result is any existing
 642 ;;; LAYOUT for this name.
 643 (defun insured-find-class (name predicate constructor)
 644   (declare (function predicate constructor))
 645   (let* ((old (sb!xc:find-class name nil))
 646          (res (if (and old (funcall predicate old))
 647                   old
 648                   (funcall constructor :name name)))
 649          (found (or (gethash name *forward-referenced-layouts*)
 650                     (when old (class-layout old)))))
 651     (when found
 652       (setf (layout-class found) res))
 653     (values res found)))
 654
 655 ;;; If the class has a proper name, return the name, otherwise return
 656 ;;; the class.
 657 (defun class-proper-name (class)
 658   #-sb-xc (declare (type sb!xc:class class))
 659   (let ((name (sb!xc:class-name class)))
 660     (if (and name (eq (sb!xc:find-class name nil) class))
 661         name
 662         class)))
 663 \f
 664 ;;;; CLASS type operations
 665
 666 (define-type-class sb!xc:class)
 667
 668 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
 669 ;;; the two classes are equal, since there are EQ checks in those
 670 ;;; operations.
 671 (define-type-method (sb!xc:class :simple-=) (type1 type2)
 672   (assert (not (eq type1 type2)))
 673   (values nil t))
 674
 675 (define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
 676   (assert (not (eq class1 class2)))
 677   (let ((subclasses (class-subclasses class2)))
 678     (if (and subclasses (gethash class1 subclasses))
 679         (values t t)
 680         (values nil t))))
 681
 682 ;;; When finding the intersection of a sealed class and some other
 683 ;;; class (not hierarchically related) the intersection is the union
 684 ;;; of the currently shared subclasses.
 685 (defun sealed-class-intersection (sealed other)
 686   (declare (type sb!xc:class sealed other))
 687   (let ((s-sub (class-subclasses sealed))
 688         (o-sub (class-subclasses other)))
 689     (if (and s-sub o-sub)
 690         (collect ((res *empty-type* type-union))
 691           (dohash (subclass layout s-sub)
 692             (declare (ignore layout))
 693             (when (gethash subclass o-sub)
 694               (res (specifier-type subclass))))
 695           (values (res) t))
 696         (values *empty-type* t))))
 697
 698 ;;; If one is a subclass of the other, then that is the intersection,
 699 ;;; but we can only be sure the intersection is otherwise empty if
 700 ;;; they are structure classes, since a subclass of both might be
 701 ;;; defined. If either class is sealed, we can eliminate this
 702 ;;; possibility.
 703 (define-type-method (sb!xc:class :simple-intersection) (class1 class2)
 704   (declare (type sb!xc:class class1 class2))
 705   (cond ((eq class1 class2) class1)
 706         ((let ((subclasses (class-subclasses class2)))
 707            (and subclasses (gethash class1 subclasses)))
 708          (values class1 t))
 709         ((let ((subclasses (class-subclasses class1)))
 710            (and subclasses (gethash class2 subclasses)))
 711          (values class2 t))
 712         ((or (basic-structure-class-p class1)
 713              (basic-structure-class-p class2))
 714          (values *empty-type* t))
 715         ((eq (class-state class1) :sealed)
 716          (sealed-class-intersection class1 class2))
 717         ((eq (class-state class2) :sealed)
 718          (sealed-class-intersection class2 class1))
 719         (t
 720          (values class1 nil))))
 721
 722 (define-type-method (sb!xc:class :unparse) (type)
 723   (class-proper-name type))
 724 \f
 725 ;;;; PCL stuff
 726
 727 (def!struct (std-class (:include sb!xc:class)
 728                        (:constructor nil)))
 729 (def!struct (sb!xc:standard-class (:include std-class)
 730                                   (:constructor bare-make-standard-class)))
 731 (def!struct (random-pcl-class (:include std-class)
 732                               (:constructor bare-make-random-pcl-class)))
 733 (defun make-standard-class (&rest rest)
 734   (apply #'bare-make-standard-class
 735          (rename-keyword-args '((:name :%name)) rest)))
 736 (defun make-random-pcl-class (&rest rest)
 737   (apply #'bare-make-random-pcl-class
 738          (rename-keyword-args '((:name :%name)) rest)))
 739 \f
 740 ;;;; built-in classes
 741
 742 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
 743 ;;; creation of all the built-in classes. It contains all the info
 744 ;;; that we need to maintain the mapping between classes, compile-time
 745 ;;; types and run-time type codes. These options are defined:
 746 ;;;
 747 ;;; :TRANSLATION (default none)
 748 ;;;     When this class is "parsed" as a type specifier, it is
 749 ;;;     translated into the specified internal type representation,
 750 ;;;     rather than being left as a class. This is used for types
 751 ;;;     which we want to canonicalize to some other kind of type
 752 ;;;     object because in general we want to be able to include more
 753 ;;;     information than just the class (e.g. for numeric types.)
 754 ;;;
 755 ;;; :ENUMERABLE (default NIL)
 756 ;;;     The value of the :ENUMERABLE slot in the created class.
 757 ;;;     Meaningless in translated classes.
 758 ;;;
 759 ;;; :STATE (default :SEALED)
 760 ;;;     The value of CLASS-STATE which we want on completion,
 761 ;;;     indicating whether subclasses can be created at run-time.
 762 ;;;
 763 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
 764 ;;;     True if we can assign this class a unique inheritance depth.
 765 ;;;
 766 ;;; :CODES (default none)
 767 ;;;     Run-time type codes which should be translated back to this
 768 ;;;     class by CLASS-OF. Unspecified for abstract classes.
 769 ;;;
 770 ;;; :INHERITS (default this class and T)
 771 ;;;     The class-precedence list for this class, with this class and
 772 ;;;     T implicit.
 773 ;;;
 774 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
 775 ;;;     List of the direct superclasses of this class.
 776 ;;;
 777 ;;; FIXME: This doesn't seem to be needed after cold init (and so can
 778 ;;; probably be uninterned at the end of cold init).
 779 (defvar *built-in-classes*)
 780 (!cold-init-forms
 781   (/show0 "setting *BUILT-IN-CLASSES*")
 782   (setq
 783    *built-in-classes*
 784    '((t :state :read-only :translation t)
 785      (character :enumerable t :translation base-char)
 786      (base-char :enumerable t
 787                 :inherits (character)
 788                 :codes (#.sb!vm:base-char-type))
 789      (symbol :codes (#.sb!vm:symbol-header-type))
 790
 791      (instance :state :read-only)
 792
 793      (system-area-pointer :codes (#.sb!vm:sap-type))
 794      (weak-pointer :codes (#.sb!vm:weak-pointer-type))
 795      (code-component :codes (#.sb!vm:code-header-type))
 796      #!-gengc (lra :codes (#.sb!vm:return-pc-header-type))
 797      (fdefn :codes (#.sb!vm:fdefn-type))
 798      (random-class) ; used for unknown type codes
 799
 800      (function
 801       :codes (#.sb!vm:byte-code-closure-type
 802               #.sb!vm:byte-code-function-type
 803               #.sb!vm:closure-header-type
 804               #.sb!vm:function-header-type)
 805       :state :read-only)
 806      (funcallable-instance
 807       :inherits (function)
 808       :state :read-only)
 809
 810      ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything
 811      ;; any more? COLLECTION is not defined in ANSI Common Lisp..
 812      (collection :hierarchical-p nil :state :read-only)
 813      (mutable-collection :state :read-only
 814                          :inherits (collection))
 815      (generic-sequence :state :read-only
 816                        :inherits (collection))
 817      (mutable-sequence :state :read-only
 818                        :direct-superclasses (mutable-collection
 819                                              generic-sequence)
 820                        :inherits (mutable-collection
 821                                   generic-sequence
 822                                   collection))
 823      (generic-array :state :read-only
 824                     :inherits (mutable-sequence
 825                                mutable-collection
 826                                generic-sequence
 827                                collection))
 828      (generic-vector :state :read-only
 829                      :inherits (generic-array
 830                                 mutable-sequence mutable-collection
 831                                 generic-sequence collection))
 832      (array :translation array :codes (#.sb!vm:complex-array-type)
 833             :inherits (generic-array mutable-sequence mutable-collection
 834                                      generic-sequence collection))
 835      (simple-array
 836       :translation simple-array :codes (#.sb!vm:simple-array-type)
 837       :inherits (array generic-array mutable-sequence mutable-collection
 838                  generic-sequence collection))
 839      (sequence
 840       :translation (or cons (member nil) vector)
 841       :inherits (mutable-sequence mutable-collection generic-sequence
 842                  collection))
 843      (vector
 844       :translation vector :codes (#.sb!vm:complex-vector-type)
 845       :direct-superclasses (array sequence generic-vector)
 846       :inherits (array sequence generic-vector generic-array
 847                  mutable-sequence mutable-collection generic-sequence
 848                  collection))
 849      (simple-vector
 850       :translation simple-vector :codes (#.sb!vm:simple-vector-type)
 851       :direct-superclasses (vector simple-array)
 852       :inherits (vector simple-array array
 853                  sequence generic-vector generic-array
 854                  mutable-sequence mutable-collection
 855                  generic-sequence collection))
 856      (bit-vector
 857       :translation bit-vector :codes (#.sb!vm:complex-bit-vector-type)
 858       :inherits (vector array sequence
 859                  generic-vector generic-array mutable-sequence
 860                  mutable-collection generic-sequence collection))
 861      (simple-bit-vector
 862       :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-type)
 863       :direct-superclasses (bit-vector simple-array)
 864       :inherits (bit-vector vector simple-array
 865                  array sequence
 866                  generic-vector generic-array mutable-sequence
 867                  mutable-collection generic-sequence collection))
 868      (simple-array-unsigned-byte-2
 869       :translation (simple-array (unsigned-byte 2) (*))
 870       :codes (#.sb!vm:simple-array-unsigned-byte-2-type)
 871       :direct-superclasses (vector simple-array)
 872       :inherits (vector simple-array array sequence
 873                  generic-vector generic-array mutable-sequence
 874                  mutable-collection generic-sequence collection))
 875      (simple-array-unsigned-byte-4
 876       :translation (simple-array (unsigned-byte 4) (*))
 877       :codes (#.sb!vm:simple-array-unsigned-byte-4-type)
 878       :direct-superclasses (vector simple-array)
 879       :inherits (vector simple-array array sequence
 880                  generic-vector generic-array mutable-sequence
 881                  mutable-collection generic-sequence collection))
 882      (simple-array-unsigned-byte-8
 883       :translation (simple-array (unsigned-byte 8) (*))
 884       :codes (#.sb!vm:simple-array-unsigned-byte-8-type)
 885       :direct-superclasses (vector simple-array)
 886       :inherits (vector simple-array array sequence
 887                  generic-vector generic-array mutable-sequence
 888                  mutable-collection generic-sequence collection))
 889      (simple-array-unsigned-byte-16
 890      :translation (simple-array (unsigned-byte 16) (*))
 891      :codes (#.sb!vm:simple-array-unsigned-byte-16-type)
 892      :direct-superclasses (vector simple-array)
 893      :inherits (vector simple-array array sequence
 894                 generic-vector generic-array mutable-sequence
 895                 mutable-collection generic-sequence collection))
 896      (simple-array-unsigned-byte-32
 897      :translation (simple-array (unsigned-byte 32) (*))
 898      :codes (#.sb!vm:simple-array-unsigned-byte-32-type)
 899      :direct-superclasses (vector simple-array)
 900      :inherits (vector simple-array array sequence
 901                 generic-vector generic-array mutable-sequence
 902                 mutable-collection generic-sequence collection))
 903      (simple-array-signed-byte-8
 904      :translation (simple-array (signed-byte 8) (*))
 905      :codes (#.sb!vm:simple-array-signed-byte-8-type)
 906      :direct-superclasses (vector simple-array)
 907      :inherits (vector simple-array array sequence
 908                 generic-vector generic-array mutable-sequence
 909                 mutable-collection generic-sequence collection))
 910      (simple-array-signed-byte-16
 911      :translation (simple-array (signed-byte 16) (*))
 912      :codes (#.sb!vm:simple-array-signed-byte-16-type)
 913      :direct-superclasses (vector simple-array)
 914      :inherits (vector simple-array array sequence
 915                 generic-vector generic-array mutable-sequence
 916                 mutable-collection generic-sequence collection))
 917      (simple-array-signed-byte-30
 918      :translation (simple-array (signed-byte 30) (*))
 919      :codes (#.sb!vm:simple-array-signed-byte-30-type)
 920      :direct-superclasses (vector simple-array)
 921      :inherits (vector simple-array array sequence
 922                 generic-vector generic-array mutable-sequence
 923                 mutable-collection generic-sequence collection))
 924      (simple-array-signed-byte-32
 925      :translation (simple-array (signed-byte 32) (*))
 926      :codes (#.sb!vm:simple-array-signed-byte-32-type)
 927      :direct-superclasses (vector simple-array)
 928      :inherits (vector simple-array array sequence
 929                 generic-vector generic-array mutable-sequence
 930                 mutable-collection generic-sequence collection))
 931      (simple-array-single-float
 932      :translation (simple-array single-float (*))
 933      :codes (#.sb!vm:simple-array-single-float-type)
 934      :direct-superclasses (vector simple-array)
 935      :inherits (vector simple-array array sequence
 936                 generic-vector generic-array mutable-sequence
 937                 mutable-collection generic-sequence collection))
 938      (simple-array-double-float
 939      :translation (simple-array double-float (*))
 940      :codes (#.sb!vm:simple-array-double-float-type)
 941      :direct-superclasses (vector simple-array)
 942      :inherits (vector simple-array array sequence
 943                 generic-vector generic-array mutable-sequence
 944                 mutable-collection generic-sequence collection))
 945     #!+long-float
 946     (simple-array-long-float
 947      :translation (simple-array long-float (*))
 948      :codes (#.sb!vm:simple-array-long-float-type)
 949      :direct-superclasses (vector simple-array)
 950      :inherits (vector simple-array array sequence
 951                 generic-vector generic-array mutable-sequence
 952                 mutable-collection generic-sequence collection))
 953     (simple-array-complex-single-float
 954      :translation (simple-array (complex single-float) (*))
 955      :codes (#.sb!vm:simple-array-complex-single-float-type)
 956      :direct-superclasses (vector simple-array)
 957      :inherits (vector simple-array array sequence
 958                 generic-vector generic-array mutable-sequence
 959                 mutable-collection generic-sequence collection))
 960     (simple-array-complex-double-float
 961      :translation (simple-array (complex double-float) (*))
 962      :codes (#.sb!vm:simple-array-complex-double-float-type)
 963      :direct-superclasses (vector simple-array)
 964      :inherits (vector simple-array array sequence
 965                 generic-vector generic-array mutable-sequence
 966                 mutable-collection generic-sequence collection))
 967     #!+long-float
 968     (simple-array-complex-long-float
 969      :translation (simple-array (complex long-float) (*))
 970      :codes (#.sb!vm:simple-array-complex-long-float-type)
 971      :direct-superclasses (vector simple-array)
 972      :inherits (vector simple-array array sequence
 973                 generic-vector generic-array mutable-sequence
 974                 mutable-collection generic-sequence collection))
 975     (generic-string
 976      :state :read-only
 977      :inherits (mutable-sequence mutable-collection generic-sequence
 978                 collection))
 979     (string
 980      :translation string
 981      :codes (#.sb!vm:complex-string-type)
 982      :direct-superclasses (vector generic-string)
 983      :inherits (vector array sequence
 984                 generic-vector generic-array generic-string
 985                 mutable-sequence mutable-collection
 986                 generic-sequence collection))
 987     (simple-string
 988      :translation simple-string
 989      :codes (#.sb!vm:simple-string-type)
 990      :direct-superclasses (string simple-array)
 991      :inherits (string vector simple-array
 992                 array sequence
 993                 generic-string generic-vector generic-array mutable-sequence
 994                 mutable-collection generic-sequence collection))
 995     (generic-number :state :read-only)
 996     (number :translation number :inherits (generic-number))
 997     (complex
 998      :translation complex
 999      :inherits (number generic-number)
1000      :codes (#.sb!vm:complex-type))
1001     (complex-single-float
1002      :translation (complex single-float)
1003      :inherits (complex number generic-number)
1004      :codes (#.sb!vm:complex-single-float-type))
1005     (complex-double-float
1006      :translation (complex double-float)
1007      :inherits (complex number generic-number)
1008      :codes (#.sb!vm:complex-double-float-type))
1009     #!+long-float
1010     (complex-long-float
1011      :translation (complex long-float)
1012      :inherits (complex number generic-number)
1013      :codes (#.sb!vm:complex-long-float-type))
1014     (real :translation real :inherits (number generic-number))
1015     (float
1016      :translation float
1017      :inherits (real number generic-number))
1018     (single-float
1019      :translation single-float
1020      :inherits (float real number generic-number)
1021      :codes (#.sb!vm:single-float-type))
1022     (double-float
1023      :translation double-float
1024      :inherits (float real number generic-number)
1025      :codes (#.sb!vm:double-float-type))
1026     #!+long-float
1027     (long-float
1028      :translation long-float
1029      :inherits (float real number generic-number)
1030      :codes (#.sb!vm:long-float-type))
1031     (rational
1032      :translation rational
1033      :inherits (real number generic-number))
1034     (ratio
1035      :translation (and rational (not integer))
1036      :inherits (rational real number generic-number)
1037      :codes (#.sb!vm:ratio-type))
1038     (integer
1039      :translation integer
1040      :inherits (rational real number generic-number))
1041     (fixnum
1042      :translation (integer #.sb!vm:*target-most-negative-fixnum*
1043                            #.sb!vm:*target-most-positive-fixnum*)
1044      :inherits (integer rational real number
1045                 generic-number)
1046      :codes (#.sb!vm:even-fixnum-type #.sb!vm:odd-fixnum-type))
1047     (bignum
1048      :translation (and integer (not fixnum))
1049      :inherits (integer rational real number
1050                 generic-number)
1051      :codes (#.sb!vm:bignum-type))
1052
1053     (list
1054      :translation (or cons (member nil))
1055      :inherits (sequence mutable-sequence mutable-collection
1056                 generic-sequence collection))
1057     (cons
1058      :codes (#.sb!vm:list-pointer-type)
1059      :inherits (list sequence
1060                 mutable-sequence mutable-collection
1061                 generic-sequence collection))
1062     (null
1063      :translation (member nil)
1064      :inherits (list sequence
1065                 mutable-sequence mutable-collection
1066                 generic-sequence collection symbol)
1067      :direct-superclasses (list symbol))
1068     (stream
1069      :hierarchical-p nil
1070      :state :read-only
1071      :inherits (instance t)))))
1072
1073 ;;; comment from CMU CL:
1074 ;;;   See also type-init.lisp where we finish setting up the
1075 ;;;   translations for built-in types.
1076 (!cold-init-forms
1077   #-sb-xc-host (/show0 "about to loop over *BUILT-IN-CLASSES*")
1078   (dolist (x *built-in-classes*)
1079     #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
1080     (destructuring-bind
1081         (name &key
1082               (translation nil trans-p)
1083               inherits
1084               codes
1085               enumerable
1086               state
1087               (hierarchical-p t) ; might be modified below
1088               (direct-superclasses (if inherits
1089                                      (list (car inherits))
1090                                      '(t))))
1091         x
1092       (declare (ignore codes state translation))
1093       (let ((inherits-list (if (eq name 't)
1094                              ()
1095                              (cons 't (reverse inherits))))
1096             (class (make-built-in-class
1097                     :enumerable enumerable
1098                     :name name
1099                     :translation (if trans-p :initializing nil)
1100                     :direct-superclasses
1101                     (if (eq name 't)
1102                       nil
1103                       (mapcar #'sb!xc:find-class direct-superclasses)))))
1104         (setf (info :type :kind name) :primitive
1105               (class-cell-class (find-class-cell name)) class)
1106         (unless trans-p
1107           (setf (info :type :builtin name) class))
1108         (let* ((inherits-vector
1109                 (map 'vector
1110                      (lambda (x)
1111                        (let ((super-layout
1112                               (class-layout (sb!xc:find-class x))))
1113                          (when (minusp (layout-depthoid super-layout))
1114                            (setf hierarchical-p nil))
1115                          super-layout))
1116                      inherits-list))
1117                (depthoid (if hierarchical-p (length inherits-vector) -1)))
1118           (register-layout
1119            (find-and-init-or-check-layout name
1120                                           0
1121                                           inherits-vector
1122                                           depthoid)
1123            :invalidate nil)))))
1124   #-sb-xc-host (/show0 "done with loop over *BUILT-IN-CLASSES*"))
1125
1126 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1127 ;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
1128 ;;; is loaded and the class defined.
1129 (!cold-init-forms
1130   (dolist (x '((fundamental-stream (t instance stream))))
1131     (let* ((name (first x))
1132            (inherits-list (second x))
1133            (class (make-standard-class :name name))
1134            (class-cell (find-class-cell name)))
1135       (setf (class-cell-class class-cell) class
1136             (info :type :class name) class-cell
1137             (info :type :kind name) :instance)
1138       (let ((inherits (map 'vector
1139                            (lambda (x)
1140                              (class-layout (sb!xc:find-class x)))
1141                            inherits-list)))
1142         (register-layout (find-and-init-or-check-layout name 0 inherits -1)
1143                          :invalidate nil)))))
1144
1145 ;;; Now that we have set up the class heterarchy, seal the sealed
1146 ;;; classes. This must be done after the subclasses have been set up.
1147 (!cold-init-forms
1148   (dolist (x *built-in-classes*)
1149     (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
1150       (setf (class-state (sb!xc:find-class name)) state))))
1151 \f
1152 ;;;; class definition/redefinition
1153
1154 ;;; This is to be called whenever we are altering a class.
1155 (defun modify-class (class)
1156   (clear-type-caches)
1157   (when (member (class-state class) '(:read-only :frozen))
1158     ;; FIXME: This should probably be CERROR.
1159     (warn "making ~(~A~) class ~S writable"
1160           (class-state class)
1161           (sb!xc:class-name class))
1162     (setf (class-state class) nil)))
1163
1164 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1165 ;;; structure type tests to fail. Remove class from all superclasses
1166 ;;; too (might not be registered, so might not be in subclasses of the
1167 ;;; nominal superclasses.)
1168 (defun invalidate-layout (layout)
1169   (declare (type layout layout))
1170   (setf (layout-invalid layout) t
1171         (layout-depthoid layout) -1)
1172   (let ((inherits (layout-inherits layout))
1173         (class (layout-class layout)))
1174     (modify-class class)
1175     (dotimes (i (length inherits)) ; FIXME: DOVECTOR
1176       (let* ((super (svref inherits i))
1177              (subs (class-subclasses (layout-class super))))
1178         (when subs
1179           (remhash class subs)))))
1180   (values))
1181 \f
1182 ;;;; cold loading initializations
1183
1184 ;;; FIXME: It would be good to arrange for this to be called when the
1185 ;;; cross-compiler is being built, not just when the target Lisp is
1186 ;;; being cold loaded. Perhaps this could be moved to its own file
1187 ;;; late in the stems-and-flags.lisp-expr sequence, and be put in
1188 ;;; !COLD-INIT-FORMS there?
1189 (defun !class-finalize ()
1190   (dohash (name layout *forward-referenced-layouts*)
1191     (let ((class (sb!xc:find-class name nil)))
1192       (cond ((not class)
1193              (setf (layout-class layout) (make-undefined-class name)))
1194             ((eq (class-layout class) layout)
1195              (remhash name *forward-referenced-layouts*))
1196             (t
1197              ;; FIXME: ERROR?
1198              (warn "something strange with forward layout for ~S:~%  ~S"
1199                    name
1200                    layout))))))
1201
1202 ;;; a vector that maps type codes to layouts, used for quickly finding
1203 ;;; the layouts of built-in classes
1204 (defvar *built-in-class-codes*) ; initialized in cold load
1205 (declaim (type simple-vector *built-in-class-codes*))
1206
1207 (!cold-init-forms
1208   #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
1209   (setq *built-in-class-codes*
1210         (let* ((initial-element
1211                 (locally
1212                   ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
1213                   ;; constant class names which creates fast but
1214                   ;; non-cold-loadable, non-compact code. In this
1215                   ;; context, we'd rather have compact, cold-loadable
1216                   ;; code. -- WHN 19990928
1217                   (declare (notinline sb!xc:find-class))
1218                   (class-layout (sb!xc:find-class 'random-class))))
1219                (res (make-array 256 :initial-element initial-element)))
1220           (dolist (x *built-in-classes* res)
1221             (destructuring-bind (name &key codes &allow-other-keys)
1222                                 x
1223               (let ((layout (class-layout (sb!xc:find-class name))))
1224                 (dolist (code codes)
1225                   (setf (svref res code) layout)))))))
1226   #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
1227 \f
1228 (!defun-from-collected-cold-init-forms !classes-cold-init)