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