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.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!KERNEL")
  15
  16 (!begin-collecting-cold-init-forms)
  17 \f
  18 ;;;; the CLASSOID structure
  19
  20 ;;; The CLASSOID structure is a supertype of all classoid types.  A
  21 ;;; CLASSOID is also a CTYPE structure as recognized by the type
  22 ;;; system.  (FIXME: It's also a type specifier, though this might go
  23 ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
  24 ;;; longer necessary)
  25 (def!struct (classoid
  26              (:make-load-form-fun classoid-make-load-form-fun)
  27              (:include ctype
  28                        (class-info (type-class-or-lose 'classoid)))
  29              (:constructor nil)
  30              #-no-ansi-print-object
  31              (:print-object
  32               (lambda (class stream)
  33                 (let ((name (classoid-name class)))
  34                   (print-unreadable-object (class stream
  35                                                   :type t
  36                                                   :identity (not name))
  37                     (format stream
  38                             ;; FIXME: Make sure that this prints
  39                             ;; reasonably for anonymous classes.
  40                             "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
  41                             name
  42                             (classoid-state class))))))
  43              #-sb-xc-host (:pure nil))
  44   ;; the value to be returned by CLASSOID-NAME.
  45   (name nil :type symbol)
  46   ;; the current layout for this class, or NIL if none assigned yet
  47   (layout nil :type (or layout null))
  48   ;; How sure are we that this class won't be redefined?
  49   ;;   :READ-ONLY = We are committed to not changing the effective
  50   ;;                slots or superclasses.
  51   ;;   :SEALED    = We can't even add subclasses.
  52   ;;   NIL        = Anything could happen.
  53   (state nil :type (member nil :read-only :sealed))
  54   ;; direct superclasses of this class
  55   (direct-superclasses () :type list)
  56   ;; representation of all of the subclasses (direct or indirect) of
  57   ;; this class. This is NIL if no subclasses or not initalized yet;
  58   ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
  59   ;; subclass layout that was in effect at the time the subclass was
  60   ;; created.
  61   (subclasses nil :type (or null hash-table))
  62   ;; the PCL class (= CL:CLASS, but with a view to future flexibility
  63   ;; we don't just call it the CLASS slot) object for this class, or
  64   ;; NIL if none assigned yet
  65   (pcl-class nil))
  66
  67 (defun classoid-make-load-form-fun (class)
  68   (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
  69   (let ((name (classoid-name class)))
  70     (unless (and name (eq (find-classoid name nil) class))
  71       (/show "anonymous/undefined class case")
  72       (error "can't use anonymous or undefined class as constant:~%  ~S"
  73              class))
  74     `(locally
  75        ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
  76        ;; class names which creates fast but non-cold-loadable,
  77        ;; non-compact code. In this context, we'd rather have compact,
  78        ;; cold-loadable code. -- WHN 19990928
  79        (declare (notinline find-classoid))
  80        (find-classoid ',name))))
  81 \f
  82 ;;;; basic LAYOUT stuff
  83
  84 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
  85 ;;; in order to guarantee that several hash values can be added without
  86 ;;; overflowing into a bignum.
  87 (def!constant layout-clos-hash-max (ash sb!xc:most-positive-fixnum -3)
  88   #!+sb-doc
  89   "the inclusive upper bound on LAYOUT-CLOS-HASH values")
  90
  91 ;;; a list of conses, initialized by genesis
  92 ;;;
  93 ;;; In each cons, the car is the symbol naming the layout, and the
  94 ;;; cdr is the layout itself.
  95 (defvar *!initial-layouts*)
  96
  97 ;;; a table mapping class names to layouts for classes we have
  98 ;;; referenced but not yet loaded. This is initialized from an alist
  99 ;;; created by genesis describing the layouts that genesis created at
 100 ;;; cold-load time.
 101 (defvar *forward-referenced-layouts*)
 102 (!cold-init-forms
 103   (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
 104   #-sb-xc-host (progn
 105                  (/show0 "processing *!INITIAL-LAYOUTS*")
 106                  (dolist (x *!initial-layouts*)
 107                    (setf (gethash (car x) *forward-referenced-layouts*)
 108                          (cdr x)))
 109                  (/show0 "done processing *!INITIAL-LAYOUTS*")))
 110
 111 ;;; The LAYOUT structure is pointed to by the first cell of instance
 112 ;;; (or structure) objects. It represents what we need to know for
 113 ;;; type checking and garbage collection. Whenever a class is
 114 ;;; incompatibly redefined, a new layout is allocated. If two object's
 115 ;;; layouts are EQ, then they are exactly the same type.
 116 (def!struct (layout
 117              ;; KLUDGE: A special hack keeps this from being
 118              ;; called when building code for the
 119              ;; cross-compiler. See comments at the DEFUN for
 120              ;; this. -- WHN 19990914
 121              (:make-load-form-fun #-sb-xc-host ignore-it
 122                                   ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
 123                                   ;; time controls both the
 124                                   ;; build-the-cross-compiler behavior
 125                                   ;; and the run-the-cross-compiler
 126                                   ;; behavior. The value below only
 127                                   ;; works for build-the-cross-compiler.
 128                                   ;; There's a special hack in
 129                                   ;; EMIT-MAKE-LOAD-FORM which gives
 130                                   ;; effectively IGNORE-IT behavior for
 131                                   ;; LAYOUT at run-the-cross-compiler
 132                                   ;; time. It would be cleaner to
 133                                   ;; actually have an IGNORE-IT value
 134                                   ;; stored, but it's hard to see how to
 135                                   ;; do that concisely with the current
 136                                   ;; DEF!STRUCT setup. -- WHN 19990930
 137                                   #+sb-xc-host
 138                                   make-load-form-for-layout))
 139   ;; hash bits which should be set to constant pseudo-random values
 140   ;; for use by CLOS. Sleazily accessed via %INSTANCE-REF, see
 141   ;; LAYOUT-CLOS-HASH.
 142   ;;
 143   ;; FIXME: We should get our story straight on what the type of these
 144   ;; values is. (declared INDEX here, described as <=
 145   ;; LAYOUT-CLOS-HASH-MAX by the doc string of that constant,
 146   ;; generated as strictly positive in RANDOM-LAYOUT-CLOS-HASH..)
 147   ;;
 148   ;; [ CSR notes, several years later (2005-11-30) that the value 0 is
 149   ;;   special for these hash slots, indicating that the wrapper is
 150   ;;   obsolete. ]
 151   ;;
 152   ;; KLUDGE: The fact that the slots here start at offset 1 is known
 153   ;; to the LAYOUT-CLOS-HASH function and to the LAYOUT-dumping code
 154   ;; in GENESIS.
 155   (clos-hash-0 (random-layout-clos-hash) :type index)
 156   (clos-hash-1 (random-layout-clos-hash) :type index)
 157   (clos-hash-2 (random-layout-clos-hash) :type index)
 158   (clos-hash-3 (random-layout-clos-hash) :type index)
 159   (clos-hash-4 (random-layout-clos-hash) :type index)
 160   (clos-hash-5 (random-layout-clos-hash) :type index)
 161   (clos-hash-6 (random-layout-clos-hash) :type index)
 162   (clos-hash-7 (random-layout-clos-hash) :type index)
 163   ;; the class that this is a layout for
 164   (classoid (missing-arg) :type classoid)
 165   ;; The value of this slot can be:
 166   ;;   * :UNINITIALIZED if not initialized yet;
 167   ;;   * NIL if this is the up-to-date layout for a class; or
 168   ;;   * T if this layout has been invalidated (by being replaced by
 169   ;;     a new, more-up-to-date LAYOUT).
 170   ;;   * something else (probably a list) if the class is a PCL wrapper
 171   ;;     and PCL has made it invalid and made a note to itself about it
 172   (invalid :uninitialized :type (or cons (member nil t :uninitialized)))
 173   ;; the layouts for all classes we inherit. If hierarchical, i.e. if
 174   ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
 175   ;; (least to most specific), so that each inherited layout appears
 176   ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
 177   ;;
 178   ;; Remaining elements are filled by the non-hierarchical layouts or,
 179   ;; if they would otherwise be empty, by copies of succeeding layouts.
 180   (inherits #() :type simple-vector)
 181   ;; If inheritance is not hierarchical, this is -1. If inheritance is
 182   ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
 183   ;; Note:
 184   ;;  (1) This turns out to be a handy encoding for arithmetically
 185   ;;      comparing deepness; it is generally useful to do a bare numeric
 186   ;;      comparison of these depthoid values, and we hardly ever need to
 187   ;;      test whether the values are negative or not.
 188   ;;  (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
 189   ;;      renamed because some of us find it confusing to call something
 190   ;;      a depth when it isn't quite.
 191   (depthoid -1 :type layout-depthoid)
 192   ;; the number of top level descriptor cells in each instance
 193   (length 0 :type index)
 194   ;; If this layout has some kind of compiler meta-info, then this is
 195   ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
 196   (info nil)
 197   ;; This is true if objects of this class are never modified to
 198   ;; contain dynamic pointers in their slots or constant-like
 199   ;; substructure (and hence can be copied into read-only space by
 200   ;; PURIFY).
 201   ;;
 202   ;; This slot is known to the C runtime support code.
 203   (pure nil :type (member t nil 0))
 204   ;; Number of raw words at the end.
 205   ;; This slot is known to the C runtime support code.
 206   (n-untagged-slots 0 :type index)
 207   ;; Definition location
 208   (source-location nil))
 209
 210 (def!method print-object ((layout layout) stream)
 211   (print-unreadable-object (layout stream :type t :identity t)
 212     (format stream
 213             "for ~S~@[, INVALID=~S~]"
 214             (layout-proper-name layout)
 215             (layout-invalid layout))))
 216
 217 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 218   (defun layout-proper-name (layout)
 219     (classoid-proper-name (layout-classoid layout))))
 220 \f
 221 ;;;; support for the hash values used by CLOS when working with LAYOUTs
 222
 223 (def!constant layout-clos-hash-length 8)
 224 #!-sb-fluid (declaim (inline layout-clos-hash))
 225 (defun layout-clos-hash (layout i)
 226   ;; FIXME: Either this I should be declared to be `(MOD
 227   ;; ,LAYOUT-CLOS-HASH-LENGTH), or this is used in some inner loop
 228   ;; where we can't afford to check that kind of thing and therefore
 229   ;; should have some insane level of optimization. (This is true both
 230   ;; of this function and of the SETF function below.)
 231   (declare (type layout layout) (type index i))
 232   ;; FIXME: LAYOUT slots should have type `(MOD ,LAYOUT-CLOS-HASH-MAX),
 233   ;; not INDEX.
 234   (truly-the index (%instance-ref layout (1+ i))))
 235 #!-sb-fluid (declaim (inline (setf layout-clos-hash)))
 236 (defun (setf layout-clos-hash) (new-value layout i)
 237   (declare (type layout layout) (type index new-value i))
 238   (setf (%instance-ref layout (1+ i)) new-value))
 239
 240 ;;; a generator for random values suitable for the CLOS-HASH slots of
 241 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
 242 ;;; pseudo-random values to come the same way in the target even when
 243 ;;; we make minor changes to the system, in order to reduce the
 244 ;;; mysteriousness of possible CLOS bugs.
 245 (defvar *layout-clos-hash-random-state*)
 246 (defun random-layout-clos-hash ()
 247   ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
 248   ;; returning a strictly positive value. I copied it verbatim from
 249   ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
 250   ;; dunno whether the hash values are really supposed to be 1-based.
 251   ;; They're declared as INDEX.. Or is this a hack to try to avoid
 252   ;; having to use bignum arithmetic? Or what? An explanation would be
 253   ;; nice.
 254   ;;
 255   ;; an explanation is provided in Kiczales and Rodriguez, "Efficient
 256   ;; Method Dispatch in PCL", 1990.  -- CSR, 2005-11-30
 257   (1+ (random layout-clos-hash-max
 258               (if (boundp '*layout-clos-hash-random-state*)
 259                   *layout-clos-hash-random-state*
 260                   (setf *layout-clos-hash-random-state*
 261                         (make-random-state))))))
 262 \f
 263 ;;; If we can't find any existing layout, then we create a new one
 264 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
 265 ;;; used to immediately check for compatibility, but for
 266 ;;; cross-compilability reasons (i.e. convenience of using this
 267 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
 268 ;;; been split off into INIT-OR-CHECK-LAYOUT.
 269 (declaim (ftype (function (symbol) layout) find-layout))
 270 (defun find-layout (name)
 271   (let ((classoid (find-classoid name nil)))
 272     (or (and classoid (classoid-layout classoid))
 273         (gethash name *forward-referenced-layouts*)
 274         (setf (gethash name *forward-referenced-layouts*)
 275               (make-layout :classoid (or classoid
 276                                          (make-undefined-classoid name)))))))
 277
 278 ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
 279 ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
 280 ;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
 281 ;;;
 282 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
 283 ;;; anything about the class", so if LAYOUT is initialized, any
 284 ;;; preexisting class slot value is OK, and if it's not initialized,
 285 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
 286 ;;; is no longer true, :UNINITIALIZED used instead.
 287 (declaim (ftype (function (layout classoid index simple-vector layout-depthoid
 288                                   index)
 289                           layout)
 290                 init-or-check-layout))
 291 (defun init-or-check-layout
 292     (layout classoid length inherits depthoid nuntagged)
 293   (cond ((eq (layout-invalid layout) :uninitialized)
 294          ;; There was no layout before, we just created one which
 295          ;; we'll now initialize with our information.
 296          (setf (layout-length layout) length
 297                (layout-inherits layout) inherits
 298                (layout-depthoid layout) depthoid
 299                (layout-n-untagged-slots layout) nuntagged
 300                (layout-classoid layout) classoid
 301                (layout-invalid layout) nil))
 302         ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
 303         ;; clause is not needed?
 304         ((not *type-system-initialized*)
 305          (setf (layout-classoid layout) classoid))
 306         (t
 307          ;; There was an old layout already initialized with old
 308          ;; information, and we'll now check that old information
 309          ;; which was known with certainty is consistent with current
 310          ;; information which is known with certainty.
 311          (check-layout layout classoid length inherits depthoid nuntagged)))
 312   layout)
 313
 314 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the
 315 ;;; standard load form mechanism, we use special fops instead, in
 316 ;;; order to make cold load come out right. But when we're building
 317 ;;; the cross-compiler, we can't do that because we don't have access
 318 ;;; to special non-ANSI low-level things like special fops, and we
 319 ;;; don't need to do that anyway because our code isn't going to be
 320 ;;; cold loaded, so we use the ordinary load form system.
 321 ;;;
 322 ;;; KLUDGE: A special hack causes this not to be called when we are
 323 ;;; building code for the target Lisp. It would be tidier to just not
 324 ;;; have it in place when we're building the target Lisp, but it
 325 ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
 326 ;;; bit, so I punted. -- WHN 19990914
 327 #+sb-xc-host
 328 (defun make-load-form-for-layout (layout &optional env)
 329   (declare (type layout layout))
 330   (declare (ignore env))
 331   (when (layout-invalid layout)
 332     (compiler-error "can't dump reference to obsolete class: ~S"
 333                     (layout-classoid layout)))
 334   (let ((name (classoid-name (layout-classoid layout))))
 335     (unless name
 336       (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
 337     ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
 338     ;; we have to do this in two stages, like the TREE-WITH-PARENT
 339     ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
 340     (values
 341      ;; "creation" form (which actually doesn't create a new LAYOUT if
 342      ;; there's a preexisting one with this name)
 343      `(find-layout ',name)
 344      ;; "initialization" form (which actually doesn't initialize
 345      ;; preexisting LAYOUTs, just checks that they're consistent).
 346      `(init-or-check-layout ',layout
 347                             ',(layout-classoid layout)
 348                             ',(layout-length layout)
 349                             ',(layout-inherits layout)
 350                             ',(layout-depthoid layout)
 351                             ',(layout-n-untagged-slots layout)))))
 352
 353 ;;; If LAYOUT's slot values differ from the specified slot values in
 354 ;;; any interesting way, then give a warning and return T.
 355 (declaim (ftype (function (simple-string
 356                            layout
 357                            simple-string
 358                            index
 359                            simple-vector
 360                            layout-depthoid
 361                            index))
 362                 redefine-layout-warning))
 363 (defun redefine-layout-warning (old-context old-layout
 364                                 context length inherits depthoid nuntagged)
 365   (declare (type layout old-layout) (type simple-string old-context context))
 366   (let ((name (layout-proper-name old-layout)))
 367     (or (let ((old-inherits (layout-inherits old-layout)))
 368           (or (when (mismatch old-inherits
 369                               inherits
 370                               :key #'layout-proper-name)
 371                 (warn "change in superclasses of class ~S:~%  ~
 372                        ~A superclasses: ~S~%  ~
 373                        ~A superclasses: ~S"
 374                       name
 375                       old-context
 376                       (map 'list #'layout-proper-name old-inherits)
 377                       context
 378                       (map 'list #'layout-proper-name inherits))
 379                 t)
 380               (let ((diff (mismatch old-inherits inherits)))
 381                 (when diff
 382                   (warn
 383                    "in class ~S:~%  ~
 384                     ~:(~A~) definition of superclass ~S is incompatible with~%  ~
 385                     ~A definition."
 386                    name
 387                    old-context
 388                    (layout-proper-name (svref old-inherits diff))
 389                    context)
 390                   t))))
 391         (let ((old-length (layout-length old-layout)))
 392           (unless (= old-length length)
 393             (warn "change in instance length of class ~S:~%  ~
 394                    ~A length: ~W~%  ~
 395                    ~A length: ~W"
 396                   name
 397                   old-context old-length
 398                   context length)
 399             t))
 400         (let ((old-nuntagged (layout-n-untagged-slots old-layout)))
 401           (unless (= old-nuntagged nuntagged)
 402             (warn "change in instance layout of class ~S:~%  ~
 403                    ~A untagged slots: ~W~%  ~
 404                    ~A untagged slots: ~W"
 405                   name
 406                   old-context old-nuntagged
 407                   context nuntagged)
 408             t))
 409         (unless (= (layout-depthoid old-layout) depthoid)
 410           (warn "change in the inheritance structure of class ~S~%  ~
 411                  between the ~A definition and the ~A definition"
 412                 name old-context context)
 413           t))))
 414
 415 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
 416 ;;; INHERITS, and DEPTHOID.
 417 (declaim (ftype (function
 418                  (layout classoid index simple-vector layout-depthoid index))
 419                 check-layout))
 420 (defun check-layout (layout classoid length inherits depthoid nuntagged)
 421   (aver (eq (layout-classoid layout) classoid))
 422   (when (redefine-layout-warning "current" layout
 423                                  "compile time" length inherits depthoid
 424                                  nuntagged)
 425     ;; Classic CMU CL had more options here. There are several reasons
 426     ;; why they might want more options which are less appropriate for
 427     ;; us: (1) It's hard to fit the classic CMU CL flexible approach
 428     ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
 429     ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
 430     ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
 431     ;; We have CLOS now, and if you want to be able to flexibly
 432     ;; redefine classes without restarting the system, it'd make sense
 433     ;; to use that, so supporting complexity in order to allow
 434     ;; modifying DEFSTRUCTs without restarting the system is a low
 435     ;; priority. (3) We now have the ability to rebuild the SBCL
 436     ;; system from scratch, so we no longer need this functionality in
 437     ;; order to maintain the SBCL system by modifying running images.
 438     (error "The class ~S was not changed, and there's no guarantee that~@
 439             the loaded code (which expected another layout) will work."
 440            (layout-proper-name layout)))
 441   (values))
 442
 443 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
 444 ;;; single function call
 445 ;;;
 446 ;;; Used by the loader to forward-reference layouts for classes whose
 447 ;;; definitions may not have been loaded yet. This allows type tests
 448 ;;; to be loaded when the type definition hasn't been loaded yet.
 449 (declaim (ftype (function (symbol index simple-vector layout-depthoid index)
 450                           layout)
 451                 find-and-init-or-check-layout))
 452 (defun find-and-init-or-check-layout (name length inherits depthoid nuntagged)
 453   (let ((layout (find-layout name)))
 454     (init-or-check-layout layout
 455                           (or (find-classoid name nil)
 456                               (layout-classoid layout))
 457                           length
 458                           inherits
 459                           depthoid
 460                           nuntagged)))
 461
 462 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
 463 ;;; of all superclasses. This is the operation that "installs" a
 464 ;;; layout for a class in the type system, clobbering any old layout.
 465 ;;; However, this does not modify the class namespace; that is a
 466 ;;; separate operation (think anonymous classes.)
 467 ;;; -- If INVALIDATE, then all the layouts for any old definition
 468 ;;;    and subclasses are invalidated, and the SUBCLASSES slot is cleared.
 469 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
 470 ;;;    destructively modified to hold the same type information.
 471 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 472 (defun register-layout (layout &key (invalidate t) destruct-layout)
 473   (declare (type layout layout) (type (or layout null) destruct-layout))
 474   (let* ((classoid (layout-classoid layout))
 475          (classoid-layout (classoid-layout classoid))
 476          (subclasses (classoid-subclasses classoid)))
 477
 478     ;; Attempting to register ourselves with a temporary undefined
 479     ;; class placeholder is almost certainly a programmer error. (I
 480     ;; should know, I did it.) -- WHN 19990927
 481     (aver (not (undefined-classoid-p classoid)))
 482
 483     ;; This assertion dates from classic CMU CL. The rationale is
 484     ;; probably that calling REGISTER-LAYOUT more than once for the
 485     ;; same LAYOUT is almost certainly a programmer error.
 486     (aver (not (eq classoid-layout layout)))
 487
 488     ;; Figure out what classes are affected by the change, and issue
 489     ;; appropriate warnings and invalidations.
 490     (when classoid-layout
 491       (modify-classoid classoid)
 492       (when subclasses
 493         (dohash (subclass subclass-layout subclasses)
 494           (modify-classoid subclass)
 495           (when invalidate
 496             (invalidate-layout subclass-layout))))
 497       (when invalidate
 498         (invalidate-layout classoid-layout)
 499         (setf (classoid-subclasses classoid) nil)))
 500
 501     (if destruct-layout
 502         (setf (layout-invalid destruct-layout) nil
 503               (layout-inherits destruct-layout) (layout-inherits layout)
 504               (layout-depthoid destruct-layout)(layout-depthoid layout)
 505               (layout-length destruct-layout) (layout-length layout)
 506               (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
 507               (layout-info destruct-layout) (layout-info layout)
 508               (classoid-layout classoid) destruct-layout)
 509         (setf (layout-invalid layout) nil
 510               (classoid-layout classoid) layout))
 511
 512     (dovector (super-layout (layout-inherits layout))
 513       (let* ((super (layout-classoid super-layout))
 514              (subclasses (or (classoid-subclasses super)
 515                              (setf (classoid-subclasses super)
 516                                    (make-hash-table :test 'eq)))))
 517         (when (and (eq (classoid-state super) :sealed)
 518                    (not (gethash classoid subclasses)))
 519           (warn "unsealing sealed class ~S in order to subclass it"
 520                 (classoid-name super))
 521           (setf (classoid-state super) :read-only))
 522         (setf (gethash classoid subclasses)
 523               (or destruct-layout layout)))))
 524
 525   (values))
 526 ); EVAL-WHEN
 527
 528 ;;; Arrange the inherited layouts to appear at their expected depth,
 529 ;;; ensuring that hierarchical type tests succeed. Layouts with
 530 ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
 531 ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
 532 ;;; layouts are placed in remaining elements. Then, any still-empty
 533 ;;; elements are filled with their successors, ensuring that each
 534 ;;; element contains a valid layout.
 535 ;;;
 536 ;;; This reordering may destroy CPL ordering, so the inherits should
 537 ;;; not be read as being in CPL order.
 538 (defun order-layout-inherits (layouts)
 539   (declare (simple-vector layouts))
 540   (let ((length (length layouts))
 541         (max-depth -1))
 542     (dotimes (i length)
 543       (let ((depth (layout-depthoid (svref layouts i))))
 544         (when (> depth max-depth)
 545           (setf max-depth depth))))
 546     (let* ((new-length (max (1+ max-depth) length))
 547            ;; KLUDGE: 0 here is the "uninitialized" element.  We need
 548            ;; to specify it explicitly for portability purposes, as
 549            ;; elements can be read before being set [ see below, "(EQL
 550            ;; OLD-LAYOUT 0)" ].  -- CSR, 2002-04-20
 551            (inherits (make-array new-length :initial-element 0)))
 552       (dotimes (i length)
 553         (let* ((layout (svref layouts i))
 554                (depth (layout-depthoid layout)))
 555           (unless (eql depth -1)
 556             (let ((old-layout (svref inherits depth)))
 557               (unless (or (eql old-layout 0) (eq old-layout layout))
 558                 (error "layout depth conflict: ~S~%" layouts)))
 559             (setf (svref inherits depth) layout))))
 560       (do ((i 0 (1+ i))
 561            (j 0))
 562           ((>= i length))
 563         (declare (type index i j))
 564         (let* ((layout (svref layouts i))
 565                (depth (layout-depthoid layout)))
 566           (when (eql depth -1)
 567             (loop (when (eql (svref inherits j) 0)
 568                     (return))
 569                   (incf j))
 570             (setf (svref inherits j) layout))))
 571       (do ((i (1- new-length) (1- i)))
 572           ((< i 0))
 573         (declare (type fixnum i))
 574         (when (eql (svref inherits i) 0)
 575           (setf (svref inherits i) (svref inherits (1+ i)))))
 576       inherits)))
 577 \f
 578 ;;;; class precedence lists
 579
 580 ;;; Topologically sort the list of objects to meet a set of ordering
 581 ;;; constraints given by pairs (A . B) constraining A to precede B.
 582 ;;; When there are multiple objects to choose, the tie-breaker
 583 ;;; function is called with both the list of object to choose from and
 584 ;;; the reverse ordering built so far.
 585 (defun topological-sort (objects constraints tie-breaker)
 586   (declare (list objects constraints)
 587            (function tie-breaker))
 588   (let ((obj-info (make-hash-table :size (length objects)))
 589         (free-objs nil)
 590         (result nil))
 591     (dolist (constraint constraints)
 592       (let ((obj1 (car constraint))
 593             (obj2 (cdr constraint)))
 594         (let ((info2 (gethash obj2 obj-info)))
 595           (if info2
 596               (incf (first info2))
 597               (setf (gethash obj2 obj-info) (list 1))))
 598         (let ((info1 (gethash obj1 obj-info)))
 599           (if info1
 600               (push obj2 (rest info1))
 601               (setf (gethash obj1 obj-info) (list 0 obj2))))))
 602     (dolist (obj objects)
 603       (let ((info (gethash obj obj-info)))
 604         (when (or (not info) (zerop (first info)))
 605           (push obj free-objs))))
 606     (loop
 607      (flet ((next-result (obj)
 608               (push obj result)
 609               (dolist (successor (rest (gethash obj obj-info)))
 610                 (let* ((successor-info (gethash successor obj-info))
 611                        (count (1- (first successor-info))))
 612                   (setf (first successor-info) count)
 613                   (when (zerop count)
 614                     (push successor free-objs))))))
 615        (cond ((endp free-objs)
 616               (dohash (obj info obj-info)
 617                 (unless (zerop (first info))
 618                   (error "Topological sort failed due to constraint on ~S."
 619                          obj)))
 620               (return (nreverse result)))
 621              ((endp (rest free-objs))
 622               (next-result (pop free-objs)))
 623              (t
 624               (let ((obj (funcall tie-breaker free-objs result)))
 625                 (setf free-objs (remove obj free-objs))
 626                 (next-result obj))))))))
 627
 628
 629 ;;; standard class precedence list computation
 630 (defun std-compute-class-precedence-list (class)
 631   (let ((classes nil)
 632         (constraints nil))
 633     (labels ((note-class (class)
 634                (unless (member class classes)
 635                  (push class classes)
 636                  (let ((superclasses (classoid-direct-superclasses class)))
 637                    (do ((prev class)
 638                         (rest superclasses (rest rest)))
 639                        ((endp rest))
 640                      (let ((next (first rest)))
 641                        (push (cons prev next) constraints)
 642                        (setf prev next)))
 643                    (dolist (class superclasses)
 644                      (note-class class)))))
 645              (std-cpl-tie-breaker (free-classes rev-cpl)
 646                (dolist (class rev-cpl (first free-classes))
 647                  (let* ((superclasses (classoid-direct-superclasses class))
 648                         (intersection (intersection free-classes
 649                                                     superclasses)))
 650                    (when intersection
 651                      (return (first intersection)))))))
 652       (note-class class)
 653       (topological-sort classes constraints #'std-cpl-tie-breaker))))
 654 \f
 655 ;;;; object types to represent classes
 656
 657 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
 658 ;;; referenced layouts. Users should never see them.
 659 (def!struct (undefined-classoid
 660              (:include classoid)
 661              (:constructor make-undefined-classoid (name))))
 662
 663 ;;; BUILT-IN-CLASS is used to represent the standard classes that
 664 ;;; aren't defined with DEFSTRUCT and other specially implemented
 665 ;;; primitive types whose only attribute is their name.
 666 ;;;
 667 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
 668 ;;; are effectively DEFTYPE'd to some other type (usually a union of
 669 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
 670 ;;; This translation is done when type specifiers are parsed. Type
 671 ;;; system operations (union, subtypep, etc.) should never encounter
 672 ;;; translated classes, only their translation.
 673 (def!struct (built-in-classoid (:include classoid)
 674                                (:constructor make-built-in-classoid))
 675   ;; the type we translate to on parsing. If NIL, then this class
 676   ;; stands on its own; or it can be set to :INITIALIZING for a period
 677   ;; during cold-load.
 678   (translation nil :type (or ctype (member nil :initializing))))
 679
 680 ;;; STRUCTURE-CLASS represents what we need to know about structure
 681 ;;; classes. Non-structure "typed" defstructs are a special case, and
 682 ;;; don't have a corresponding class.
 683 (def!struct (structure-classoid (:include classoid)
 684                                 (:constructor make-structure-classoid))
 685   ;; If true, a default keyword constructor for this structure.
 686   (constructor nil :type (or function null)))
 687 \f
 688 ;;;; classoid namespace
 689
 690 ;;; We use an indirection to allow forward referencing of class
 691 ;;; definitions with load-time resolution.
 692 (def!struct (classoid-cell
 693              (:constructor make-classoid-cell (name &optional classoid))
 694              (:make-load-form-fun (lambda (c)
 695                                     `(find-classoid-cell
 696                                       ',(classoid-cell-name c))))
 697              #-no-ansi-print-object
 698              (:print-object (lambda (s stream)
 699                               (print-unreadable-object (s stream :type t)
 700                                 (prin1 (classoid-cell-name s) stream)))))
 701   ;; Name of class we expect to find.
 702   (name nil :type symbol :read-only t)
 703   ;; Class or NIL if not yet defined.
 704   (classoid nil :type (or classoid null)))
 705 (defun find-classoid-cell (name)
 706   (or (info :type :classoid name)
 707       (setf (info :type :classoid name)
 708             (make-classoid-cell name))))
 709
 710 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 711 (defun find-classoid (name &optional (errorp t) environment)
 712   #!+sb-doc
 713   "Return the class with the specified NAME. If ERRORP is false, then
 714 NIL is returned when no such class exists."
 715   (declare (type symbol name) (ignore environment))
 716   (let ((res (classoid-cell-classoid (find-classoid-cell name))))
 717     (if (or res (not errorp))
 718         res
 719         (error 'simple-type-error
 720                :datum nil
 721                :expected-type 'class
 722                :format-control "class not yet defined:~%  ~S"
 723                :format-arguments (list name)))))
 724 (defun (setf find-classoid) (new-value name)
 725   #-sb-xc (declare (type (or null classoid) new-value))
 726   (cond
 727     ((null new-value)
 728      (ecase (info :type :kind name)
 729        ((nil))
 730        (:defined)
 731        (:primitive
 732         (error "attempt to redefine :PRIMITIVE type: ~S" name))
 733        ((:forthcoming-defclass-type :instance)
 734         (setf (info :type :kind name) nil
 735               (info :type :classoid name) nil
 736               (info :type :documentation name) nil
 737               (info :type :compiler-layout name) nil))))
 738     (t
 739      (ecase (info :type :kind name)
 740        ((nil))
 741        (:forthcoming-defclass-type
 742         ;; XXX Currently, nothing needs to be done in this
 743         ;; case. Later, when PCL is integrated tighter into SBCL, this
 744         ;; might need more work.
 745         nil)
 746        (:instance
 747         ;; KLUDGE: The reason these clauses aren't directly parallel
 748         ;; is that we need to use the internal CLASSOID structure
 749         ;; ourselves, because we don't have CLASSes to work with until
 750         ;; PCL is built.  In the host, CLASSes have an approximately
 751         ;; one-to-one correspondence with the target CLASSOIDs (as
 752         ;; well as with the target CLASSes, modulo potential
 753         ;; differences with respect to conditions).
 754         #+sb-xc-host
 755         (let ((old (class-of (find-classoid name)))
 756               (new (class-of new-value)))
 757           (unless (eq old new)
 758             (bug "trying to change the metaclass of ~S from ~S to ~S in the ~
 759                   cross-compiler."
 760                  name (class-name old) (class-name new))))
 761         #-sb-xc-host
 762         (let ((old (classoid-of (find-classoid name)))
 763               (new (classoid-of new-value)))
 764           (unless (eq old new)
 765             (warn "changing meta-class of ~S from ~S to ~S"
 766                   name (classoid-name old) (classoid-name new)))))
 767        (:primitive
 768         (error "illegal to redefine standard type ~S" name))
 769        (:defined
 770            (warn "redefining DEFTYPE type to be a class: ~S" name)
 771            (setf (info :type :expander name) nil)))
 772
 773      (remhash name *forward-referenced-layouts*)
 774      (%note-type-defined name)
 775      ;; we need to handle things like
 776      ;;   (setf (find-class 'foo) (find-class 'integer))
 777      ;; and
 778      ;;   (setf (find-class 'integer) (find-class 'integer))
 779      (cond
 780        ((built-in-classoid-p new-value)
 781         (setf (info :type :kind name) (or (info :type :kind name) :defined))
 782         (let ((translation (built-in-classoid-translation new-value)))
 783           (when translation
 784             (setf (info :type :translator name)
 785                   (lambda (c) (declare (ignore c)) translation)))))
 786        (t (setf (info :type :kind name) :instance)))
 787      (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
 788      (unless (eq (info :type :compiler-layout name)
 789                  (classoid-layout new-value))
 790        (setf (info :type :compiler-layout name) (classoid-layout new-value)))))
 791   new-value)
 792 ) ; EVAL-WHEN
 793
 794 ;;; Called when we are about to define NAME as a class meeting some
 795 ;;; predicate (such as a meta-class type test.) The first result is
 796 ;;; always of the desired class. The second result is any existing
 797 ;;; LAYOUT for this name.
 798 (defun insured-find-classoid (name predicate constructor)
 799   (declare (type function predicate constructor))
 800   (let* ((old (find-classoid name nil))
 801          (res (if (and old (funcall predicate old))
 802                   old
 803                   (funcall constructor :name name)))
 804          (found (or (gethash name *forward-referenced-layouts*)
 805                     (when old (classoid-layout old)))))
 806     (when found
 807       (setf (layout-classoid found) res))
 808     (values res found)))
 809
 810 ;;; If the class has a proper name, return the name, otherwise return
 811 ;;; the class.
 812 (defun classoid-proper-name (class)
 813   #-sb-xc (declare (type classoid class))
 814   (let ((name (classoid-name class)))
 815     (if (and name (eq (find-classoid name nil) class))
 816         name
 817         class)))
 818 \f
 819 ;;;; CLASS type operations
 820
 821 (!define-type-class classoid)
 822
 823 ;;; We might be passed classoids with invalid layouts; in any pairwise
 824 ;;; class comparison, we must ensure that both are valid before
 825 ;;; proceeding.
 826 (defun ensure-classoid-valid (classoid layout)
 827   (aver (eq classoid (layout-classoid layout)))
 828   (when (layout-invalid layout)
 829     (if (typep classoid 'standard-classoid)
 830         (let ((class (classoid-pcl-class classoid)))
 831           (cond
 832             ((sb!pcl:class-finalized-p class)
 833              (sb!pcl::force-cache-flushes class))
 834             ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
 835              (error "Invalid, unfinalizeable class ~S (classoid ~S)."
 836                     class classoid))
 837             (t (sb!pcl:finalize-inheritance class))))
 838         (error "Don't know how to ensure validity of ~S (not ~
 839                 a STANDARD-CLASSOID)." classoid))))
 840
 841 (defun ensure-both-classoids-valid (class1 class2)
 842   (do ((layout1 (classoid-layout class1) (classoid-layout class1))
 843        (layout2 (classoid-layout class2) (classoid-layout class2))
 844        (i 0 (+ i 1)))
 845       ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
 846     (aver (< i 2))
 847     (ensure-classoid-valid class1 layout1)
 848     (ensure-classoid-valid class2 layout2)))
 849
 850 (defun update-object-layout-or-invalid (object layout)
 851   (if (typep (classoid-of object) 'standard-classoid)
 852       (sb!pcl::check-wrapper-validity object)
 853       (%layout-invalid-error object layout)))
 854
 855 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
 856 ;;; the two classes are equal, since there are EQ checks in those
 857 ;;; operations.
 858 (!define-type-method (classoid :simple-=) (type1 type2)
 859   (aver (not (eq type1 type2)))
 860   (values nil t))
 861
 862 (!define-type-method (classoid :simple-subtypep) (class1 class2)
 863   (aver (not (eq class1 class2)))
 864   (ensure-both-classoids-valid class1 class2)
 865   (let ((subclasses (classoid-subclasses class2)))
 866     (if (and subclasses (gethash class1 subclasses))
 867         (values t t)
 868         (values nil t))))
 869
 870 ;;; When finding the intersection of a sealed class and some other
 871 ;;; class (not hierarchically related) the intersection is the union
 872 ;;; of the currently shared subclasses.
 873 (defun sealed-class-intersection2 (sealed other)
 874   (declare (type classoid sealed other))
 875   (let ((s-sub (classoid-subclasses sealed))
 876         (o-sub (classoid-subclasses other)))
 877     (if (and s-sub o-sub)
 878         (collect ((res *empty-type* type-union))
 879           (dohash (subclass layout s-sub)
 880             (declare (ignore layout))
 881             (when (gethash subclass o-sub)
 882               (res (specifier-type subclass))))
 883           (res))
 884         *empty-type*)))
 885
 886 (!define-type-method (classoid :simple-intersection2) (class1 class2)
 887   (declare (type classoid class1 class2))
 888   (ensure-both-classoids-valid class1 class2)
 889   (cond ((eq class1 class2)
 890          class1)
 891         ;; If one is a subclass of the other, then that is the
 892         ;; intersection.
 893         ((let ((subclasses (classoid-subclasses class2)))
 894            (and subclasses (gethash class1 subclasses)))
 895          class1)
 896         ((let ((subclasses (classoid-subclasses class1)))
 897            (and subclasses (gethash class2 subclasses)))
 898          class2)
 899         ;; Otherwise, we can't in general be sure that the
 900         ;; intersection is empty, since a subclass of both might be
 901         ;; defined. But we can eliminate it for some special cases.
 902         ((or (structure-classoid-p class1)
 903              (structure-classoid-p class2))
 904          ;; No subclass of both can be defined.
 905          *empty-type*)
 906         ((eq (classoid-state class1) :sealed)
 907          ;; checking whether a subclass of both can be defined:
 908          (sealed-class-intersection2 class1 class2))
 909         ((eq (classoid-state class2) :sealed)
 910          ;; checking whether a subclass of both can be defined:
 911          (sealed-class-intersection2 class2 class1))
 912         (t
 913          ;; uncertain, since a subclass of both might be defined
 914          nil)))
 915
 916 ;;; KLUDGE: we need this for the special-case SEQUENCE type, which
 917 ;;; (because of multiple inheritance with ARRAY for the VECTOR types)
 918 ;;; doesn't have the nice hierarchical properties we want.  This is
 919 ;;; basically DELEGATE-COMPLEX-INTERSECTION2 with a special-case for
 920 ;;; SEQUENCE/ARRAY interactions.
 921 (!define-type-method (classoid :complex-intersection2) (type1 class2)
 922   (cond
 923     ((and (eq class2 (find-classoid 'sequence))
 924           (array-type-p type1))
 925      (type-intersection2 (specifier-type 'vector) type1))
 926     (t
 927      (let ((method (type-class-complex-intersection2 (type-class-info type1))))
 928        (if (and method (not (eq method #'delegate-complex-intersection2)))
 929            :call-other-method
 930            (hierarchical-intersection2 type1 class2))))))
 931
 932 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
 933 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
 934 ;;; discovered that this was incompatible with the MOP class
 935 ;;; hierarchy).  See NAMED :COMPLEX-SUBTYPEP-ARG2
 936 (defvar *non-instance-classoid-types*
 937   '(symbol system-area-pointer weak-pointer code-component
 938     lra fdefn random-class))
 939
 940 ;;; KLUDGE: we need this because of the need to represent
 941 ;;; intersections of two classes, even when empty at a given time, as
 942 ;;; uncanonicalized intersections because of the possibility of later
 943 ;;; defining a subclass of both classes.  The necessity for changing
 944 ;;; the default return value from SUBTYPEP to NIL, T if no alternate
 945 ;;; method is present comes about because, unlike the other places we
 946 ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
 947 ;;; like, classes are in their own hierarchy with no possibility of
 948 ;;; mixtures with other type classes.
 949 (!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
 950   (if (and (intersection-type-p type1)
 951            (> (count-if #'classoid-p (intersection-type-types type1)) 1))
 952       (values nil nil)
 953       (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
 954
 955 (!define-type-method (classoid :negate) (type)
 956   (make-negation-type :type type))
 957
 958 (!define-type-method (classoid :unparse) (type)
 959   (classoid-proper-name type))
 960 \f
 961 ;;;; PCL stuff
 962
 963 ;;; the CLASSOID that we use to represent type information for
 964 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.  The type system
 965 ;;; side does not need to distinguish between STANDARD-CLASS and
 966 ;;; FUNCALLABLE-STANDARD-CLASS.
 967 (def!struct (standard-classoid (:include classoid)
 968                                (:constructor make-standard-classoid)))
 969 ;;; a metaclass for classes which aren't standardlike but will never
 970 ;;; change either.
 971 (def!struct (static-classoid (:include classoid)
 972                              (:constructor make-static-classoid)))
 973 \f
 974 ;;;; built-in classes
 975
 976 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
 977 ;;; creation of all the built-in classes. It contains all the info
 978 ;;; that we need to maintain the mapping between classes, compile-time
 979 ;;; types and run-time type codes. These options are defined:
 980 ;;;
 981 ;;; :TRANSLATION (default none)
 982 ;;;     When this class is "parsed" as a type specifier, it is
 983 ;;;     translated into the specified internal type representation,
 984 ;;;     rather than being left as a class. This is used for types
 985 ;;;     which we want to canonicalize to some other kind of type
 986 ;;;     object because in general we want to be able to include more
 987 ;;;     information than just the class (e.g. for numeric types.)
 988 ;;;
 989 ;;; :ENUMERABLE (default NIL)
 990 ;;;     The value of the :ENUMERABLE slot in the created class.
 991 ;;;     Meaningless in translated classes.
 992 ;;;
 993 ;;; :STATE (default :SEALED)
 994 ;;;     The value of CLASS-STATE which we want on completion,
 995 ;;;     indicating whether subclasses can be created at run-time.
 996 ;;;
 997 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
 998 ;;;     True if we can assign this class a unique inheritance depth.
 999 ;;;
1000 ;;; :CODES (default none)
1001 ;;;     Run-time type codes which should be translated back to this
1002 ;;;     class by CLASS-OF. Unspecified for abstract classes.
1003 ;;;
1004 ;;; :INHERITS (default this class and T)
1005 ;;;     The class-precedence list for this class, with this class and
1006 ;;;     T implicit.
1007 ;;;
1008 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
1009 ;;;     List of the direct superclasses of this class.
1010 ;;;
1011 ;;; FIXME: This doesn't seem to be needed after cold init (and so can
1012 ;;; probably be uninterned at the end of cold init).
1013 (defvar *built-in-classes*)
1014 (!cold-init-forms
1015   (/show0 "setting *BUILT-IN-CLASSES*")
1016   (setq
1017    *built-in-classes*
1018    '((t :state :read-only :translation t)
1019      (character :enumerable t
1020                 :codes (#.sb!vm:character-widetag)
1021                 :translation (character-set)
1022                 :prototype-form (code-char 42))
1023      (symbol :codes (#.sb!vm:symbol-header-widetag)
1024              :prototype-form '#:mu)
1025
1026      (system-area-pointer :codes (#.sb!vm:sap-widetag)
1027                           :prototype-form (sb!sys:int-sap 42))
1028      (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)
1029       :prototype-form (sb!ext:make-weak-pointer (find-package "CL")))
1030      (code-component :codes (#.sb!vm:code-header-widetag))
1031      (lra :codes (#.sb!vm:return-pc-header-widetag))
1032      (fdefn :codes (#.sb!vm:fdefn-widetag)
1033             :prototype-form (sb!kernel:make-fdefn "42"))
1034      (random-class) ; used for unknown type codes
1035
1036      (function
1037       :codes (#.sb!vm:closure-header-widetag
1038               #.sb!vm:simple-fun-header-widetag)
1039       :state :read-only
1040       :prototype-form (function (lambda () 42)))
1041
1042      (number :translation number)
1043      (complex
1044       :translation complex
1045       :inherits (number)
1046       :codes (#.sb!vm:complex-widetag)
1047       :prototype-form (complex 42 42))
1048      (complex-single-float
1049       :translation (complex single-float)
1050       :inherits (complex number)
1051       :codes (#.sb!vm:complex-single-float-widetag)
1052       :prototype-form (complex 42f0 42f0))
1053      (complex-double-float
1054       :translation (complex double-float)
1055       :inherits (complex number)
1056       :codes (#.sb!vm:complex-double-float-widetag)
1057       :prototype-form (complex 42d0 42d0))
1058      #!+long-float
1059      (complex-long-float
1060       :translation (complex long-float)
1061       :inherits (complex number)
1062       :codes (#.sb!vm:complex-long-float-widetag)
1063       :prototype-form (complex 42l0 42l0))
1064      (real :translation real :inherits (number))
1065      (float
1066       :translation float
1067       :inherits (real number))
1068      (single-float
1069       :translation single-float
1070       :inherits (float real number)
1071       :codes (#.sb!vm:single-float-widetag)
1072       :prototype-form 42f0)
1073      (double-float
1074       :translation double-float
1075       :inherits (float real number)
1076       :codes (#.sb!vm:double-float-widetag)
1077       :prototype-form 42d0)
1078      #!+long-float
1079      (long-float
1080       :translation long-float
1081       :inherits (float real number)
1082       :codes (#.sb!vm:long-float-widetag)
1083       :prototype-form 42l0)
1084      (rational
1085       :translation rational
1086       :inherits (real number))
1087      (ratio
1088       :translation (and rational (not integer))
1089       :inherits (rational real number)
1090       :codes (#.sb!vm:ratio-widetag)
1091       :prototype-form 1/42)
1092      (integer
1093       :translation integer
1094       :inherits (rational real number))
1095      (fixnum
1096       :translation (integer #.sb!xc:most-negative-fixnum
1097                     #.sb!xc:most-positive-fixnum)
1098       :inherits (integer rational real number)
1099       :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)
1100       :prototype-form 42)
1101      (bignum
1102       :translation (and integer (not fixnum))
1103       :inherits (integer rational real number)
1104       :codes (#.sb!vm:bignum-widetag)
1105       :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2))))
1106
1107      (array :translation array :codes (#.sb!vm:complex-array-widetag)
1108             :hierarchical-p nil
1109             :prototype-form (make-array nil :adjustable t))
1110      (simple-array
1111       :translation simple-array :codes (#.sb!vm:simple-array-widetag)
1112       :inherits (array)
1113       :prototype-form (make-array nil))
1114      (sequence
1115       :state :read-only
1116       :depth 2)
1117      (vector
1118       :translation vector :codes (#.sb!vm:complex-vector-widetag)
1119       :direct-superclasses (array sequence)
1120       :inherits (array sequence))
1121      (simple-vector
1122       :translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
1123       :direct-superclasses (vector simple-array)
1124       :inherits (vector simple-array array sequence)
1125       :prototype-form (make-array 0))
1126      (bit-vector
1127       :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
1128       :inherits (vector array sequence)
1129       :prototype-form (make-array 0 :element-type 'bit :fill-pointer t))
1130      (simple-bit-vector
1131       :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
1132       :direct-superclasses (bit-vector simple-array)
1133       :inherits (bit-vector vector simple-array
1134                  array sequence)
1135       :prototype-form (make-array 0 :element-type 'bit))
1136      (simple-array-unsigned-byte-2
1137       :translation (simple-array (unsigned-byte 2) (*))
1138       :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
1139       :direct-superclasses (vector simple-array)
1140       :inherits (vector simple-array array sequence)
1141       :prototype-form (make-array 0 :element-type '(unsigned-byte 2)))
1142      (simple-array-unsigned-byte-4
1143       :translation (simple-array (unsigned-byte 4) (*))
1144       :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
1145       :direct-superclasses (vector simple-array)
1146       :inherits (vector simple-array array sequence)
1147       :prototype-form (make-array 0 :element-type '(unsigned-byte 4)))
1148      (simple-array-unsigned-byte-7
1149       :translation (simple-array (unsigned-byte 7) (*))
1150       :codes (#.sb!vm:simple-array-unsigned-byte-7-widetag)
1151       :direct-superclasses (vector simple-array)
1152       :inherits (vector simple-array array sequence)
1153       :prototype-form (make-array 0 :element-type '(unsigned-byte 7)))
1154      (simple-array-unsigned-byte-8
1155       :translation (simple-array (unsigned-byte 8) (*))
1156       :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
1157       :direct-superclasses (vector simple-array)
1158       :inherits (vector simple-array array sequence)
1159       :prototype-form (make-array 0 :element-type '(unsigned-byte 8)))
1160      (simple-array-unsigned-byte-15
1161       :translation (simple-array (unsigned-byte 15) (*))
1162       :codes (#.sb!vm:simple-array-unsigned-byte-15-widetag)
1163       :direct-superclasses (vector simple-array)
1164       :inherits (vector simple-array array sequence)
1165       :prototype-form (make-array 0 :element-type '(unsigned-byte 15)))
1166      (simple-array-unsigned-byte-16
1167       :translation (simple-array (unsigned-byte 16) (*))
1168       :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
1169       :direct-superclasses (vector simple-array)
1170       :inherits (vector simple-array array sequence)
1171       :prototype-form (make-array 0 :element-type '(unsigned-byte 16)))
1172      #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
1173      (simple-array-unsigned-byte-29
1174       :translation (simple-array (unsigned-byte 29) (*))
1175       :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag)
1176       :direct-superclasses (vector simple-array)
1177       :inherits (vector simple-array array sequence)
1178       :prototype-form (make-array 0 :element-type '(unsigned-byte 29)))
1179      (simple-array-unsigned-byte-31
1180       :translation (simple-array (unsigned-byte 31) (*))
1181       :codes (#.sb!vm:simple-array-unsigned-byte-31-widetag)
1182       :direct-superclasses (vector simple-array)
1183       :inherits (vector simple-array array sequence)
1184       :prototype-form (make-array 0 :element-type '(unsigned-byte 31)))
1185      (simple-array-unsigned-byte-32
1186       :translation (simple-array (unsigned-byte 32) (*))
1187       :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
1188       :direct-superclasses (vector simple-array)
1189       :inherits (vector simple-array array sequence)
1190       :prototype-form (make-array 0 :element-type '(unsigned-byte 32)))
1191      #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1192      (simple-array-unsigned-byte-60
1193       :translation (simple-array (unsigned-byte 60) (*))
1194       :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag)
1195       :direct-superclasses (vector simple-array)
1196       :inherits (vector simple-array array sequence)
1197       :prototype-form (make-array 0 :element-type '(unsigned-byte 60)))
1198      #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1199      (simple-array-unsigned-byte-63
1200       :translation (simple-array (unsigned-byte 63) (*))
1201       :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag)
1202       :direct-superclasses (vector simple-array)
1203       :inherits (vector simple-array array sequence)
1204       :prototype-form (make-array 0 :element-type '(unsigned-byte 63)))
1205      #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1206      (simple-array-unsigned-byte-64
1207       :translation (simple-array (unsigned-byte 64) (*))
1208       :codes (#.sb!vm:simple-array-unsigned-byte-64-widetag)
1209       :direct-superclasses (vector simple-array)
1210       :inherits (vector simple-array array sequence)
1211       :prototype-form (make-array 0 :element-type '(unsigned-byte 64)))
1212      (simple-array-signed-byte-8
1213       :translation (simple-array (signed-byte 8) (*))
1214       :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
1215       :direct-superclasses (vector simple-array)
1216       :inherits (vector simple-array array sequence)
1217       :prototype-form (make-array 0 :element-type '(signed-byte 8)))
1218      (simple-array-signed-byte-16
1219       :translation (simple-array (signed-byte 16) (*))
1220       :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
1221       :direct-superclasses (vector simple-array)
1222       :inherits (vector simple-array array sequence)
1223       :prototype-form (make-array 0 :element-type '(signed-byte 16)))
1224      #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
1225      (simple-array-signed-byte-30
1226       :translation (simple-array (signed-byte 30) (*))
1227       :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
1228       :direct-superclasses (vector simple-array)
1229       :inherits (vector simple-array array sequence)
1230       :prototype-form (make-array 0 :element-type '(signed-byte 30)))
1231      (simple-array-signed-byte-32
1232       :translation (simple-array (signed-byte 32) (*))
1233       :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
1234       :direct-superclasses (vector simple-array)
1235       :inherits (vector simple-array array sequence)
1236       :prototype-form (make-array 0 :element-type '(signed-byte 32)))
1237      #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1238      (simple-array-signed-byte-61
1239       :translation (simple-array (signed-byte 61) (*))
1240       :codes (#.sb!vm:simple-array-signed-byte-61-widetag)
1241       :direct-superclasses (vector simple-array)
1242       :inherits (vector simple-array array sequence)
1243       :prototype-form (make-array 0 :element-type '(signed-byte 61)))
1244      #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1245      (simple-array-signed-byte-64
1246       :translation (simple-array (signed-byte 64) (*))
1247       :codes (#.sb!vm:simple-array-signed-byte-64-widetag)
1248       :direct-superclasses (vector simple-array)
1249       :inherits (vector simple-array array sequence)
1250       :prototype-form (make-array 0 :element-type '(signed-byte 64)))
1251      (simple-array-single-float
1252       :translation (simple-array single-float (*))
1253       :codes (#.sb!vm:simple-array-single-float-widetag)
1254       :direct-superclasses (vector simple-array)
1255       :inherits (vector simple-array array sequence)
1256       :prototype-form (make-array 0 :element-type 'single-float))
1257      (simple-array-double-float
1258       :translation (simple-array double-float (*))
1259       :codes (#.sb!vm:simple-array-double-float-widetag)
1260       :direct-superclasses (vector simple-array)
1261       :inherits (vector simple-array array sequence)
1262       :prototype-form (make-array 0 :element-type 'double-float))
1263      #!+long-float
1264      (simple-array-long-float
1265       :translation (simple-array long-float (*))
1266       :codes (#.sb!vm:simple-array-long-float-widetag)
1267       :direct-superclasses (vector simple-array)
1268       :inherits (vector simple-array array sequence)
1269       :prototype-form (make-array 0 :element-type 'long-float))
1270      (simple-array-complex-single-float
1271       :translation (simple-array (complex single-float) (*))
1272       :codes (#.sb!vm:simple-array-complex-single-float-widetag)
1273       :direct-superclasses (vector simple-array)
1274       :inherits (vector simple-array array sequence)
1275       :prototype-form (make-array 0 :element-type '(complex single-float)))
1276      (simple-array-complex-double-float
1277       :translation (simple-array (complex double-float) (*))
1278       :codes (#.sb!vm:simple-array-complex-double-float-widetag)
1279       :direct-superclasses (vector simple-array)
1280       :inherits (vector simple-array array sequence)
1281       :prototype-form (make-array 0 :element-type '(complex double-float)))
1282      #!+long-float
1283      (simple-array-complex-long-float
1284       :translation (simple-array (complex long-float) (*))
1285       :codes (#.sb!vm:simple-array-complex-long-float-widetag)
1286       :direct-superclasses (vector simple-array)
1287       :inherits (vector simple-array array sequence)
1288       :prototype-form (make-array 0 :element-type '(complex long-float)))
1289      (string
1290       :translation string
1291       :direct-superclasses (vector)
1292       :inherits (vector array sequence))
1293      (simple-string
1294       :translation simple-string
1295       :direct-superclasses (string simple-array)
1296       :inherits (string vector simple-array array sequence))
1297      (vector-nil
1298       :translation (vector nil)
1299       :codes (#.sb!vm:complex-vector-nil-widetag)
1300       :direct-superclasses (string)
1301       :inherits (string vector array sequence)
1302       :prototype-form (make-array 0 :element-type 'nil :fill-pointer t))
1303      (simple-array-nil
1304       :translation (simple-array nil (*))
1305       :codes (#.sb!vm:simple-array-nil-widetag)
1306       :direct-superclasses (vector-nil simple-string)
1307       :inherits (vector-nil simple-string string vector simple-array
1308                  array sequence)
1309       :prototype-form (make-array 0 :element-type 'nil))
1310      (base-string
1311       :translation base-string
1312       :codes (#.sb!vm:complex-base-string-widetag)
1313       :direct-superclasses (string)
1314       :inherits (string vector array sequence)
1315       :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t))
1316      (simple-base-string
1317       :translation simple-base-string
1318       :codes (#.sb!vm:simple-base-string-widetag)
1319       :direct-superclasses (base-string simple-string)
1320       :inherits (base-string simple-string string vector simple-array
1321                  array sequence)
1322       :prototype-form (make-array 0 :element-type 'base-char))
1323      #!+sb-unicode
1324      (character-string
1325       :translation (vector character)
1326       :codes (#.sb!vm:complex-character-string-widetag)
1327       :direct-superclasses (string)
1328       :inherits (string vector array sequence)
1329       :prototype-form (make-array 0 :element-type 'character :fill-pointer t))
1330      #!+sb-unicode
1331      (simple-character-string
1332       :translation (simple-array character (*))
1333       :codes (#.sb!vm:simple-character-string-widetag)
1334       :direct-superclasses (character-string simple-string)
1335       :inherits (character-string simple-string string vector simple-array
1336                  array sequence)
1337       :prototype-form (make-array 0 :element-type 'character))
1338      (list
1339       :translation (or cons (member nil))
1340       :inherits (sequence))
1341      (cons
1342       :codes (#.sb!vm:list-pointer-lowtag)
1343       :translation cons
1344       :inherits (list sequence)
1345       :prototype-form (cons nil nil))
1346      (null
1347       :translation (member nil)
1348       :inherits (symbol list sequence)
1349       :direct-superclasses (symbol list)
1350       :prototype-form 'nil)
1351      (stream
1352       :state :read-only
1353       :depth 2)
1354      (file-stream
1355       :state :read-only
1356       :depth 4
1357       :inherits (stream))
1358      (string-stream
1359       :state :read-only
1360       :depth 4
1361       :inherits (stream)))))
1362
1363 ;;; See also src/code/class-init.lisp where we finish setting up the
1364 ;;; translations for built-in types.
1365 (!cold-init-forms
1366   (dolist (x *built-in-classes*)
1367     #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
1368     (destructuring-bind
1369         (name &key
1370               (translation nil trans-p)
1371               inherits
1372               codes
1373               enumerable
1374               state
1375               depth
1376               prototype-form
1377               (hierarchical-p t) ; might be modified below
1378               (direct-superclasses (if inherits
1379                                      (list (car inherits))
1380                                      '(t))))
1381         x
1382       (declare (ignore codes state translation prototype-form))
1383       (let ((inherits-list (if (eq name t)
1384                                ()
1385                                (cons t (reverse inherits))))
1386             (classoid (make-built-in-classoid
1387                        :enumerable enumerable
1388                        :name name
1389                        :translation (if trans-p :initializing nil)
1390                        :direct-superclasses
1391                        (if (eq name t)
1392                            nil
1393                            (mapcar #'find-classoid direct-superclasses)))))
1394         (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive
1395               (classoid-cell-classoid (find-classoid-cell name)) classoid)
1396         (unless trans-p
1397           (setf (info :type :builtin name) classoid))
1398         (let* ((inherits-vector
1399                 (map 'simple-vector
1400                      (lambda (x)
1401                        (let ((super-layout
1402                               (classoid-layout (find-classoid x))))
1403                          (when (minusp (layout-depthoid super-layout))
1404                            (setf hierarchical-p nil))
1405                          super-layout))
1406                      inherits-list))
1407                (depthoid (if hierarchical-p
1408                            (or depth (length inherits-vector))
1409                            -1)))
1410           (register-layout
1411            (find-and-init-or-check-layout name
1412                                           0
1413                                           inherits-vector
1414                                           depthoid
1415                                           0)
1416            :invalidate nil)))))
1417   (/show0 "done with loop over *BUILT-IN-CLASSES*"))
1418
1419 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1420 ;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
1421 ;;; is loaded and the class defined.
1422 (!cold-init-forms
1423   (/show0 "about to define temporary STANDARD-CLASSes")
1424   (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
1425                ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
1426                ;; a vector containing the elements of the list below,
1427                ;; i.e. '(T STREAM STREAM), is created, and
1428                ;; this is what the function ORDER-LAYOUT-INHERITS
1429                ;; would do, too.
1430                ;;
1431                ;; So, the purpose is to guarantee a valid layout for
1432                ;; the FUNDAMENTAL-STREAM class, matching what
1433                ;; ORDER-LAYOUT-INHERITS would do.
1434                ;; ORDER-LAYOUT-INHERITS would place STREAM at index 2
1435                ;; in the INHERITS(-VECTOR). Index 1 would not be
1436                ;; filled, so STREAM is duplicated there (as
1437                ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
1438                ;; duplicate definition could be removed (removing a
1439                ;; STREAM element), because FUNDAMENTAL-STREAM is
1440                ;; redefined after PCL is set up, anyway. But to play
1441                ;; it safely, we define the class with a valid INHERITS
1442                ;; vector.
1443                (fundamental-stream (t stream stream))))
1444     (/show0 "defining temporary STANDARD-CLASS")
1445     (let* ((name (first x))
1446            (inherits-list (second x))
1447            (classoid (make-standard-classoid :name name))
1448            (classoid-cell (find-classoid-cell name)))
1449       ;; Needed to open-code the MAP, below
1450       (declare (type list inherits-list))
1451       (setf (classoid-cell-classoid classoid-cell) classoid
1452             (info :type :classoid name) classoid-cell
1453             (info :type :kind name) :instance)
1454       (let ((inherits (map 'simple-vector
1455                            (lambda (x)
1456                              (classoid-layout (find-classoid x)))
1457                            inherits-list)))
1458         #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
1459         (register-layout (find-and-init-or-check-layout name 0 inherits -1 0)
1460                          :invalidate nil))))
1461   (/show0 "done defining temporary STANDARD-CLASSes"))
1462
1463 ;;; Now that we have set up the class heterarchy, seal the sealed
1464 ;;; classes. This must be done after the subclasses have been set up.
1465 (!cold-init-forms
1466   (dolist (x *built-in-classes*)
1467     (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
1468       (setf (classoid-state (find-classoid name)) state))))
1469 \f
1470 ;;;; class definition/redefinition
1471
1472 ;;; This is to be called whenever we are altering a class.
1473 (defun modify-classoid (classoid)
1474   (clear-type-caches)
1475   (when (member (classoid-state classoid) '(:read-only :frozen))
1476     ;; FIXME: This should probably be CERROR.
1477     (warn "making ~(~A~) class ~S writable"
1478           (classoid-state classoid)
1479           (classoid-name classoid))
1480     (setf (classoid-state classoid) nil)))
1481
1482 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1483 ;;; structure type tests to fail. Remove class from all superclasses
1484 ;;; too (might not be registered, so might not be in subclasses of the
1485 ;;; nominal superclasses.)  We set the layout-clos-hash slots to 0 to
1486 ;;; invalidate the wrappers for specialized dispatch functions, which
1487 ;;; use those slots as indexes into tables.
1488 (defun invalidate-layout (layout)
1489   (declare (type layout layout))
1490   (setf (layout-invalid layout) t
1491         (layout-depthoid layout) -1)
1492   (dotimes (i layout-clos-hash-length)
1493     (setf (layout-clos-hash layout i) 0))
1494   (let ((inherits (layout-inherits layout))
1495         (classoid (layout-classoid layout)))
1496     (modify-classoid classoid)
1497     (dovector (super inherits)
1498       (let ((subs (classoid-subclasses (layout-classoid super))))
1499         (when subs
1500           (remhash classoid subs)))))
1501   (values))
1502 \f
1503 ;;;; cold loading initializations
1504
1505 ;;; FIXME: It would be good to arrange for this to be called when the
1506 ;;; cross-compiler is being built, not just when the target Lisp is
1507 ;;; being cold loaded. Perhaps this could be moved to its own file
1508 ;;; late in the build-order.lisp-expr sequence, and be put in
1509 ;;; !COLD-INIT-FORMS there?
1510 (defun !class-finalize ()
1511   (dohash (name layout *forward-referenced-layouts*)
1512     (let ((class (find-classoid name nil)))
1513       (cond ((not class)
1514              (setf (layout-classoid layout) (make-undefined-classoid name)))
1515             ((eq (classoid-layout class) layout)
1516              (remhash name *forward-referenced-layouts*))
1517             (t
1518              ;; FIXME: ERROR?
1519              (warn "something strange with forward layout for ~S:~%  ~S"
1520                    name
1521                    layout))))))
1522
1523 (!cold-init-forms
1524   #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
1525   (setq *built-in-class-codes*
1526         (let* ((initial-element
1527                 (locally
1528                   ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
1529                   ;; constant class names which creates fast but
1530                   ;; non-cold-loadable, non-compact code. In this
1531                   ;; context, we'd rather have compact, cold-loadable
1532                   ;; code. -- WHN 19990928
1533                   (declare (notinline find-classoid))
1534                   (classoid-layout (find-classoid 'random-class))))
1535                (res (make-array 256 :initial-element initial-element)))
1536           (dolist (x *built-in-classes* res)
1537             (destructuring-bind (name &key codes &allow-other-keys)
1538                                 x
1539               (let ((layout (classoid-layout (find-classoid name))))
1540                 (dolist (code codes)
1541                   (setf (svref res code) layout)))))))
1542   (setq *null-classoid-layout*
1543         ;; KLUDGE: we use (LET () ...) instead of a LOCALLY here to
1544         ;; work around a bug in the LOCALLY handling in the fopcompiler
1545         ;; (present in 0.9.13-0.9.14.18). -- JES, 2006-07-16
1546         (let ()
1547           (declare (notinline find-classoid))
1548           (classoid-layout (find-classoid 'null))))
1549   #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
1550 \f
1551 (!defun-from-collected-cold-init-forms !classes-cold-init)