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